Skip to content

Commit 501f6e4

Browse files
cootcoot
committed
diffusion: public network state
1 parent 710b685 commit 501f6e4

File tree

13 files changed

+512
-88
lines changed

13 files changed

+512
-88
lines changed

‎cardano-client/src/Cardano/Client/Subscription.hs

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -50,6 +50,8 @@ import Ouroboros.Network.NodeToClient (Handshake, LocalAddress (..),
5050
NodeToClientVersion, NodeToClientVersionData (..), TraceSendRecv,
5151
Versions)
5252
import Ouroboros.Network.NodeToClient qualified as NtC
53+
import Ouroboros.Network.NodeToNode (RemoteAddress)
54+
import Ouroboros.Network.PublicState qualified as Public
5355
import Ouroboros.Network.Snocket qualified as Snocket
5456

5557
type MuxMode = Mx.Mode
@@ -104,7 +106,7 @@ subscribe
104106
-> SubscriptionParams a
105107
-> ( NodeToClientVersion
106108
-> blockVersion
107-
-> NodeToClientProtocols Mx.InitiatorMode LocalAddress BSL.ByteString IO a Void)
109+
-> NodeToClientProtocols Mx.InitiatorMode RemoteAddress LocalAddress BSL.ByteString IO a Void)
108110
-> IO ()
109111
subscribe snocket networkMagic supportedVersions
110112
SubscriptionTracers {
@@ -154,7 +156,7 @@ versionedProtocols ::
154156
-- ^ Use `supportedNodeToClientVersions` from `ouroboros-consensus`.
155157
-> ( NodeToClientVersion
156158
-> blockVersion
157-
-> NodeToClientProtocols appType LocalAddress bytes m a Void)
159+
-> NodeToClientProtocols appType RemoteAddress LocalAddress bytes m a Void)
158160
-- ^ callback which receives codecs, connection id and STM action which
159161
-- can be checked if the networking runtime system requests the protocols
160162
-- to stop.
@@ -165,7 +167,7 @@ versionedProtocols ::
165167
-> Versions
166168
NodeToClientVersion
167169
NodeToClientVersionData
168-
(OuroborosApplicationWithMinimalCtx appType () LocalAddress bytes m a Void)
170+
(OuroborosApplicationWithMinimalCtx appType (Public.NetworkState RemoteAddress) LocalAddress bytes m a Void)
169171
versionedProtocols networkMagic supportedVersions callback =
170172
NtC.foldMapVersions applyVersion (Map.toList supportedVersions)
171173
where
@@ -174,7 +176,7 @@ versionedProtocols networkMagic supportedVersions callback =
174176
-> Versions
175177
NodeToClientVersion
176178
NodeToClientVersionData
177-
(OuroborosApplicationWithMinimalCtx appType () LocalAddress bytes m a Void)
179+
(OuroborosApplicationWithMinimalCtx appType (Public.NetworkState RemoteAddress) LocalAddress bytes m a Void)
178180
applyVersion (version, blockVersion) =
179181
NtC.versionedNodeToClientProtocols
180182
version

‎ouroboros-network-api/ouroboros-network-api.cabal

Lines changed: 58 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -97,3 +97,61 @@ library
9797

9898
if flag(asserts)
9999
ghc-options: -fno-ignore-asserts
100+
101+
library testlib
102+
visibility: public
103+
hs-source-dirs: testlib
104+
exposed-modules:
105+
Test.Ouroboros.Network.PublicState.Generators
106+
107+
default-language: Haskell2010
108+
default-extensions: ImportQualifiedPost
109+
build-depends:
110+
QuickCheck,
111+
base,
112+
containers,
113+
ouroboros-network-api,
114+
115+
ghc-options:
116+
-Wall
117+
-Wno-unticked-promoted-constructors
118+
-Wcompat
119+
-Wincomplete-uni-patterns
120+
-Wincomplete-record-updates
121+
-Wpartial-fields
122+
-Widentities
123+
-Wredundant-constraints
124+
-Wunused-packages
125+
126+
if flag(asserts)
127+
ghc-options: -fno-ignore-asserts
128+
129+
test-suite test
130+
type: exitcode-stdio-1.0
131+
main-is: Main.hs
132+
hs-source-dirs: test
133+
other-modules:
134+
Test.Ouroboros.Network.PublicState
135+
136+
default-language: Haskell2010
137+
default-extensions: ImportQualifiedPost
138+
build-depends:
139+
base,
140+
bytestring,
141+
cborg,
142+
ouroboros-network-api:{ouroboros-network-api, testlib},
143+
serialise,
144+
tasty,
145+
tasty-quickcheck,
146+
with-utf8,
147+
148+
ghc-options:
149+
-Wall
150+
-Wno-unticked-promoted-constructors
151+
-Wcompat
152+
-Wincomplete-uni-patterns
153+
-Wincomplete-record-updates
154+
-Wpartial-fields
155+
-Widentities
156+
-Wredundant-constraints
157+
-Wunused-packages

‎ouroboros-network-api/test/Main.hs

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
module Main where
2+
3+
import Test.Ouroboros.Network.PublicState qualified as PublicState
4+
5+
import Main.Utf8 (withUtf8)
6+
import Test.Tasty
7+
8+
main :: IO ()
9+
main = withUtf8 $ defaultMain tests
10+
11+
tests :: TestTree
12+
tests =
13+
testGroup "ouroboros-network-api:test"
14+
[ PublicState.tests ]

‎ouroboros-network-api/test/Test/Ouroboros/Network/PublicState.hs

Lines changed: 57 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,57 @@
1+
{-# LANGUAGE FlexibleInstances #-}
2+
{-# OPTIONS_GHC -Wno-orphans #-}
3+
4+
module Test.Ouroboros.Network.PublicState where
5+
6+
import Codec.CBOR.FlatTerm qualified as CBOR
7+
import Codec.CBOR.Read qualified as CBOR
8+
import Codec.CBOR.Write qualified as CBOR
9+
import Codec.Serialise
10+
import Data.ByteString.Lazy qualified as BSL
11+
12+
import Ouroboros.Network.PublicState
13+
import Test.Ouroboros.Network.PublicState.Generators ()
14+
15+
import Test.Tasty
16+
import Test.Tasty.QuickCheck
17+
18+
19+
tests :: TestTree
20+
tests = testGroup "Test.Ouroboros.Network.PublicState"
21+
[ testGroup "CBOR"
22+
[ testProperty "round trip" prop_publicState_roundTripCBOR
23+
, testProperty "valid encoding" prop_publicState_validCBOR
24+
]
25+
]
26+
27+
28+
type Addr = Int
29+
30+
instance Serialise (RemoteAddressEncoding Addr) where
31+
encode = encode . getRemoteAddressEncoding
32+
decode = RemoteAddressEncoding <$> decode
33+
34+
prop_publicState_roundTripCBOR
35+
:: NetworkState Addr
36+
-> Property
37+
prop_publicState_roundTripCBOR ns =
38+
case CBOR.deserialiseFromBytes decodeNetworkState (CBOR.toLazyByteString (encodeNetworkState ns)) of
39+
Left e -> counterexample (show e) False
40+
Right (bs, ns') | BSL.null bs
41+
-> ns' === ns
42+
43+
| otherwise
44+
-> counterexample "left over bytes" False
45+
46+
prop_publicState_validCBOR
47+
:: NetworkState Addr
48+
-> Property
49+
prop_publicState_validCBOR ns =
50+
counterexample (show enc)
51+
. CBOR.validFlatTerm
52+
. CBOR.toFlatTerm
53+
$ enc
54+
where
55+
enc = encodeNetworkState ns
56+
57+

‎ouroboros-network-api/testlib/Test/Ouroboros/Network/PublicState/Generators.hs

Lines changed: 191 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,191 @@
1+
{-# LANGUAGE NamedFieldPuns #-}
2+
{-# OPTIONS_GHC -Wno-orphans #-}
3+
4+
module Test.Ouroboros.Network.PublicState.Generators where
5+
6+
import Data.Map.Strict qualified as Map
7+
import Data.Set (Set)
8+
import Data.Set qualified as Set
9+
10+
import Ouroboros.Network.ConnectionId
11+
import Ouroboros.Network.ConnectionManager.Public
12+
import Ouroboros.Network.PublicState
13+
14+
import Test.QuickCheck
15+
16+
17+
instance Arbitrary Provenance where
18+
arbitrary = elements [Inbound, Outbound]
19+
20+
instance Arbitrary DataFlow where
21+
arbitrary = elements [Unidirectional, Duplex]
22+
23+
instance Arbitrary TimeoutExpired where
24+
arbitrary = elements [Expired, Ticking]
25+
26+
instance Arbitrary AbstractState where
27+
arbitrary = oneof
28+
[ pure UnknownConnectionSt
29+
, pure ReservedOutboundSt
30+
, UnnegotiatedSt <$> arbitrary
31+
, InboundIdleSt <$> arbitrary
32+
, InboundSt <$> arbitrary
33+
, pure OutboundUniSt
34+
, OutboundDupSt <$> arbitrary
35+
, OutboundIdleSt <$> arbitrary
36+
, pure DuplexSt
37+
, pure WaitRemoteIdleSt
38+
, pure TerminatingSt
39+
, pure TerminatedSt
40+
]
41+
42+
toPair :: ConnectionId addr -> (addr, addr)
43+
toPair ConnectionId {remoteAddress, localAddress} = (remoteAddress, localAddress)
44+
45+
fromPair :: (addr, addr) -> ConnectionId addr
46+
fromPair (remoteAddress, localAddress) = ConnectionId {remoteAddress, localAddress}
47+
48+
instance (Ord addr, Arbitrary addr) => Arbitrary (ConnectionManagerState addr) where
49+
arbitrary = do
50+
connectionMap <- Map.fromList
51+
<$> listOf ((\(a,b,c) -> (ConnectionId a b, c))
52+
`fmap`
53+
((,,) <$> arbitrary
54+
<*> arbitrary
55+
<*> arbitrary))
56+
registered <- Set.fromList <$> arbitrary
57+
let registeredOutboundConnections =
58+
registered
59+
`Set.difference`
60+
Set.map remoteAddress (Map.keysSet connectionMap)
61+
return ConnectionManagerState {
62+
connectionMap,
63+
registeredOutboundConnections
64+
}
65+
66+
shrink a@ConnectionManagerState {
67+
connectionMap,
68+
registeredOutboundConnections
69+
} =
70+
[ a { connectionMap = connectionMap' }
71+
| connectionMap'
72+
<- Map.fromList `map` shrinkList (const []) (Map.toList connectionMap)
73+
]
74+
++
75+
[ a { registeredOutboundConnections = registeredOutboundConnections' }
76+
| registeredOutboundConnections'
77+
<- Set.fromList `map` shrinkList (const []) (Set.toList registeredOutboundConnections)
78+
]
79+
80+
disjoint3 :: Ord a => Gen a -> Gen (Set a, Set a, Set a)
81+
disjoint3 gen = do
82+
(a,b,c) <-
83+
(,,) <$> (Set.fromList <$> listOf gen)
84+
<*> (Set.fromList <$> listOf gen)
85+
<*> (Set.fromList <$> listOf gen)
86+
return ( a
87+
, b `Set.difference` a
88+
, c `Set.difference` a
89+
`Set.difference` b
90+
)
91+
92+
disjoint4 :: Ord a => Gen a -> Gen (Set a, Set a, Set a, Set a)
93+
disjoint4 gen = do
94+
(a,b,c,d) <-
95+
(,,,) <$> (Set.fromList <$> listOf gen)
96+
<*> (Set.fromList <$> listOf gen)
97+
<*> (Set.fromList <$> listOf gen)
98+
<*> (Set.fromList <$> listOf gen)
99+
return ( a
100+
, b `Set.difference` a
101+
, c `Set.difference` a
102+
`Set.difference` b
103+
, d `Set.difference` a
104+
`Set.difference` b
105+
`Set.difference` c
106+
)
107+
108+
109+
instance (Ord addr, Arbitrary addr) => Arbitrary (InboundState addr) where
110+
arbitrary = do
111+
(remoteHotSet, remoteWarmSet, remoteColdSet, remoteIdleSet)
112+
<- disjoint4 (ConnectionId <$> arbitrary <*> arbitrary)
113+
return InboundState {
114+
remoteHotSet,
115+
remoteWarmSet,
116+
remoteColdSet,
117+
remoteIdleSet
118+
}
119+
shrink a@InboundState {
120+
remoteHotSet,
121+
remoteWarmSet,
122+
remoteColdSet,
123+
remoteIdleSet
124+
} =
125+
[ a { remoteHotSet = remoteHotSet' }
126+
| remoteHotSet' <- (Set.fromList . map fromPair) `map` shrink (toPair `map` Set.toList remoteHotSet)
127+
]
128+
++
129+
[ a { remoteWarmSet = remoteWarmSet' }
130+
| remoteWarmSet' <- (Set.fromList . map fromPair) `map` shrink (toPair `map` Set.toList remoteWarmSet)
131+
]
132+
++
133+
[ a { remoteColdSet = remoteColdSet' }
134+
| remoteColdSet' <- (Set.fromList . map fromPair) `map` shrink (toPair `map` Set.toList remoteColdSet)
135+
]
136+
++
137+
[ a { remoteIdleSet = remoteIdleSet' }
138+
| remoteIdleSet' <- (Set.fromList . map fromPair) `map` shrink (toPair `map` Set.toList remoteIdleSet)
139+
]
140+
141+
instance (Ord addr, Arbitrary addr) => Arbitrary (OutboundState addr) where
142+
arbitrary = do
143+
(coldPeers, warmPeers, hotPeers)
144+
<- disjoint3 arbitrary
145+
return OutboundState {
146+
coldPeers,
147+
warmPeers,
148+
hotPeers
149+
}
150+
shrink a@OutboundState {
151+
coldPeers,
152+
warmPeers,
153+
hotPeers
154+
} =
155+
[ a { coldPeers = coldPeers' }
156+
| coldPeers' <- Set.fromList `map` shrink (Set.toList coldPeers)
157+
]
158+
++
159+
[ a { warmPeers = warmPeers' }
160+
| warmPeers' <- Set.fromList `map` shrink (Set.toList warmPeers)
161+
]
162+
++
163+
[ a { hotPeers = hotPeers' }
164+
| hotPeers' <- Set.fromList `map` shrink (Set.toList hotPeers)
165+
]
166+
167+
instance (Ord addr, Arbitrary addr) => Arbitrary (NetworkState addr) where
168+
arbitrary =
169+
NetworkState
170+
<$> arbitrary
171+
<*> arbitrary
172+
<*> arbitrary
173+
174+
shrink a@NetworkState {
175+
connectionManagerState,
176+
inboundGovernorState,
177+
outboundGovernorState
178+
} =
179+
[ a { connectionManagerState = connectionManagerState' }
180+
| connectionManagerState' <- shrink connectionManagerState
181+
]
182+
++
183+
[ a { inboundGovernorState = inboundGovernorState' }
184+
| inboundGovernorState' <- shrink inboundGovernorState
185+
]
186+
++
187+
[ a { outboundGovernorState = outboundGovernorState' }
188+
| outboundGovernorState' <- shrink outboundGovernorState
189+
]
190+
191+

‎ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@
2020
module Ouroboros.Network.InboundGovernor
2121
( -- * Run Inbound Protocol Governor
2222
PublicState (..)
23+
, toInboundState
2324
, newPublicStateVar
2425
, emptyPublicState
2526
, Arguments (..)

0 commit comments

Comments
 (0)