Skip to content

Commit 6034a80

Browse files
cootcoot
committed
srv: compliance with CIP#0155
cardano-foundation/CIPs#1033
1 parent 5554d24 commit 6034a80

File tree

14 files changed

+291
-74
lines changed

14 files changed

+291
-74
lines changed

‎decentralized-message-queue/src/DMQ/Diffusion/Arguments.hs

Lines changed: 12 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
1-
{-# LANGUAGE FlexibleContexts #-}
2-
{-# LANGUAGE KindSignatures #-}
3-
{-# LANGUAGE NamedFieldPuns #-}
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE KindSignatures #-}
3+
{-# LANGUAGE NamedFieldPuns #-}
4+
{-# LANGUAGE OverloadedStrings #-}
45

56
module DMQ.Diffusion.Arguments (diffusionArguments) where
67

@@ -24,6 +25,7 @@ import Ouroboros.Network.PeerSelection.Governor.Types
2425
(ExtraGuardedDecisions (..), PeerSelectionGovernorArgs (..))
2526
import Ouroboros.Network.PeerSelection.LedgerPeers.Type
2627
(LedgerPeersConsensusInterface (..))
28+
import Ouroboros.Network.PeerSelection.RelayAccessPoint (SRVPrefix)
2729
import Ouroboros.Network.PeerSelection.Types (nullPublicExtraPeersAPI)
2830

2931
diffusionArguments
@@ -89,4 +91,11 @@ diffusionArguments handshakeNtNTracer
8991
, Diffusion.daRequestPublicRootPeers = Nothing
9092
, Diffusion.daPeerChurnGovernor = peerChurnGovernor
9193
, Diffusion.daExtraChurnArgs = ()
94+
, Diffusion.daSRVPrefix = dmqSRVPrefix
9295
}
96+
97+
98+
-- | SRVPrefix as registerd in `CIP#0155`.
99+
--
100+
dmqSRVPrefix :: SRVPrefix
101+
dmqSRVPrefix = "_dmq._mithril._cardano._tcp"

‎ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs

Lines changed: 46 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@
44
{-# LANGUAGE DerivingVia #-}
55
{-# LANGUAGE FlexibleInstances #-}
66
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7-
{-# LANGUAGE LambdaCase #-}
7+
{-# LANGUAGE NamedFieldPuns #-}
88
{-# LANGUAGE OverloadedStrings #-}
99
{-# LANGUAGE PatternSynonyms #-}
1010
{-# LANGUAGE ScopedTypeVariables #-}
@@ -21,13 +21,20 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type
2121
, IsLedgerPeer (..)
2222
, IsBigLedgerPeer (..)
2323
, LedgerPeersConsensusInterface (..)
24+
, getRelayAccessPointsFromLedger
2425
, mapExtraAPI
2526
, UseLedgerPeers (..)
2627
, AfterSlot (..)
2728
, LedgerPeersKind (..)
2829
, LedgerPeerSnapshot (.., LedgerPeerSnapshot)
30+
, getRelayAccessPointsFromLedgerPeerSnapshot
2931
, isLedgerPeersEnabled
3032
, compareLedgerPeerSnapshotApproximate
33+
-- * Re-exports
34+
, SRVPrefix
35+
, RelayAccessPoint (..)
36+
, LedgerRelayAccessPoint (..)
37+
, prefixLedgerRelayAccessPoint
3138
) where
3239

3340
import GHC.Generics (Generic)
@@ -39,6 +46,7 @@ import Control.Concurrent.Class.MonadSTM
3946
import Control.DeepSeq (NFData (..))
4047
import Control.Monad (forM)
4148
import Data.Aeson
49+
import Data.Bifunctor (first)
4250
import Data.List.NonEmpty (NonEmpty)
4351
import NoThunks.Class
4452

@@ -49,15 +57,24 @@ import Ouroboros.Network.PeerSelection.RelayAccessPoint
4957
-- to connect to when syncing.
5058
--
5159
data LedgerPeerSnapshot =
52-
LedgerPeerSnapshotV2 (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
60+
LedgerPeerSnapshotV2 (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))])
5361
-- ^ Internal use for version 2, use pattern synonym for public API
5462
deriving (Eq, Show)
5563

64+
65+
getRelayAccessPointsFromLedgerPeerSnapshot
66+
:: SRVPrefix
67+
-> LedgerPeerSnapshot
68+
-> (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
69+
getRelayAccessPointsFromLedgerPeerSnapshot srvPrefix (LedgerPeerSnapshotV2 as) =
70+
fmap (fmap (fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix))))) as
71+
72+
5673
-- |Public API to access snapshot data. Currently access to only most recent version is available.
5774
-- Nonetheless, serialisation from the node into JSON is supported for older versions via internal
5875
-- api so that newer CLI can still support older node formats.
5976
--
60-
pattern LedgerPeerSnapshot :: (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
77+
pattern LedgerPeerSnapshot :: (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))])
6178
-> LedgerPeerSnapshot
6279
pattern LedgerPeerSnapshot payload <- LedgerPeerSnapshotV2 payload where
6380
LedgerPeerSnapshot payload = LedgerPeerSnapshotV2 payload
@@ -74,21 +91,27 @@ pattern LedgerPeerSnapshot payload <- LedgerPeerSnapshotV2 payload where
7491
-- The two approximate values should be equal if they were created
7592
-- from the same 'faithful' data.
7693
--
77-
compareLedgerPeerSnapshotApproximate :: LedgerPeerSnapshot
78-
-> LedgerPeerSnapshot
94+
compareLedgerPeerSnapshotApproximate :: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
95+
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
7996
-> Bool
8097
compareLedgerPeerSnapshotApproximate baseline candidate =
8198
case tripIt of
8299
Success candidate' -> candidate' == baseline
83100
Error _ -> False
84101
where
85-
tripIt = fromJSON . toJSON $ candidate
102+
tripIt = fmap (fmap (fmap (first unPoolStakeCoded)))
103+
. fmap (fmap (first unAccPoolStakeCoded))
104+
. fromJSON
105+
. toJSON
106+
. fmap (fmap (first PoolStakeCoded))
107+
. fmap (first AccPoolStakeCoded)
108+
$ candidate
86109

87110
-- | In case the format changes in the future, this function provides a migration functionality
88111
-- when possible.
89112
--
90113
migrateLedgerPeerSnapshot :: LedgerPeerSnapshot
91-
-> Maybe (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
114+
-> Maybe (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))])
92115
migrateLedgerPeerSnapshot (LedgerPeerSnapshotV2 lps) = Just lps
93116

94117
instance ToJSON LedgerPeerSnapshot where
@@ -118,7 +141,7 @@ instance FromJSON LedgerPeerSnapshot where
118141
return (accStake, (reStake, relays))
119142
withObject ("bigLedgerPools[" <> show idx <> "]") f (Object poolO)
120143

121-
return $ LedgerPeerSnapshotV2 (slot, bigPools')
144+
return $ LedgerPeerSnapshot (slot, bigPools')
122145
_ -> fail $ "Network.LedgerPeers.Type: parseJSON: failed to parse unsupported version " <> show vNum
123146
case migrateLedgerPeerSnapshot parsedSnapshot of
124147
Just payload -> return $ LedgerPeerSnapshot payload
@@ -198,7 +221,7 @@ newtype PoolStake = PoolStake { unPoolStake :: Rational }
198221
deriving (Eq, Ord, Show)
199222
deriving newtype (Fractional, Num, NFData)
200223

201-
newtype PoolStakeCoded = PoolStakeCoded PoolStake
224+
newtype PoolStakeCoded = PoolStakeCoded { unPoolStakeCoded :: PoolStake }
202225
deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational
203226

204227
-- | The accumulated relative stake of a stake pool, like PoolStake but it also includes the
@@ -208,7 +231,7 @@ newtype AccPoolStake = AccPoolStake { unAccPoolStake :: Rational }
208231
deriving (Eq, Ord, Show)
209232
deriving newtype (Fractional, Num)
210233

211-
newtype AccPoolStakeCoded = AccPoolStakeCoded AccPoolStake
234+
newtype AccPoolStakeCoded = AccPoolStakeCoded { unAccPoolStakeCoded :: AccPoolStake }
212235
deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational
213236

214237
-- | Identifies a peer as coming from ledger or not.
@@ -235,11 +258,23 @@ data IsBigLedgerPeer
235258
--
236259
data LedgerPeersConsensusInterface extraAPI m = LedgerPeersConsensusInterface {
237260
lpGetLatestSlot :: STM m (WithOrigin SlotNo)
238-
, lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty RelayAccessPoint)]
261+
, lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
239262
-- | Extension point so that third party users can add more actions
240263
, lpExtraAPI :: extraAPI
241264
}
242265

266+
getRelayAccessPointsFromLedger
267+
:: MonadSTM m
268+
=> SRVPrefix
269+
-> LedgerPeersConsensusInterface extraAPI m
270+
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
271+
getRelayAccessPointsFromLedger
272+
srvPrefix
273+
LedgerPeersConsensusInterface {lpGetLedgerPeers}
274+
=
275+
fmap (fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix)))) lpGetLedgerPeers
276+
277+
243278
mapExtraAPI :: (a -> b) -> LedgerPeersConsensusInterface a m -> LedgerPeersConsensusInterface b m
244279
mapExtraAPI f lpci@LedgerPeersConsensusInterface{ lpExtraAPI = api } =
245280
lpci { lpExtraAPI = f api }

‎ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Utils.hs

Lines changed: 13 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
1-
{-# LANGUAGE BangPatterns #-}
2-
{-# LANGUAGE TypeApplications #-}
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
{-# LANGUAGE TypeApplications #-}
34

45
module Ouroboros.Network.PeerSelection.LedgerPeers.Utils
56
( bigLedgerPeerQuota
@@ -18,7 +19,6 @@ import Data.Ord (Down (..))
1819
import Data.Ratio ((%))
1920

2021
import Ouroboros.Network.PeerSelection.LedgerPeers.Type
21-
import Ouroboros.Network.PeerSelection.RelayAccessPoint
2222

2323
-- | The total accumulated stake of big ledger peers.
2424
--
@@ -29,8 +29,10 @@ bigLedgerPeerQuota = 0.9
2929
-- and tag each one with cumulative stake, with a cutoff
3030
-- at 'bigLedgerPeerQuota'
3131
--
32-
accumulateBigLedgerStake :: [(PoolStake, NonEmpty RelayAccessPoint)]
33-
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
32+
accumulateBigLedgerStake
33+
:: forall relayAccessPoint.
34+
[(PoolStake, NonEmpty relayAccessPoint)]
35+
-> [(AccPoolStake, (PoolStake, NonEmpty relayAccessPoint))]
3436
accumulateBigLedgerStake =
3537
takeWhilePrev (\(acc, _) -> acc <= bigLedgerPeerQuota)
3638
. go 0
@@ -45,8 +47,8 @@ accumulateBigLedgerStake =
4547

4648
-- natural fold
4749
go :: AccPoolStake
48-
-> [(PoolStake, NonEmpty RelayAccessPoint)]
49-
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
50+
-> [(PoolStake, NonEmpty relayAccessPoint)]
51+
-> [(AccPoolStake, (PoolStake, NonEmpty relayAccessPoint))]
5052
go _acc [] = []
5153
go !acc (a@(s, _) : as) =
5254
let acc' = acc + AccPoolStake (unPoolStake s)
@@ -55,9 +57,10 @@ accumulateBigLedgerStake =
5557
-- | Not all stake pools have valid \/ usable relay information. This means that
5658
-- we need to recalculate the relative stake for each pool.
5759
--
58-
recomputeRelativeStake :: LedgerPeersKind
59-
-> [(PoolStake, NonEmpty RelayAccessPoint)]
60-
-> [(PoolStake, NonEmpty RelayAccessPoint)]
60+
recomputeRelativeStake
61+
:: LedgerPeersKind
62+
-> [(PoolStake, NonEmpty relayAccessPoint)]
63+
-> [(PoolStake, NonEmpty relayAccessPoint)]
6164
recomputeRelativeStake ledgerPeersKind pl =
6265
let pl' = first adjustment <$> pl
6366
total = List.foldl' (+) 0 (fst <$> pl')

‎ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs

Lines changed: 136 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,9 @@
66

77
module Ouroboros.Network.PeerSelection.RelayAccessPoint
88
( RelayAccessPoint (..)
9+
, LedgerRelayAccessPoint (..)
10+
, SRVPrefix
11+
, prefixLedgerRelayAccessPoint
912
, IP.IP (..)
1013
-- * Socket type re-exports
1114
, Socket.PortNumber
@@ -32,6 +35,7 @@ import Network.Socket qualified as Socket
3235
--
3336
data RelayAccessPoint = RelayAccessDomain !DNS.Domain !Socket.PortNumber
3437
| RelayAccessSRVDomain !DNS.Domain
38+
-- ^ SRV domain, prefixed (as defined in CIP#0155)
3539
| RelayAccessAddress !IP.IP !Socket.PortNumber
3640
deriving (Eq, Ord)
3741

@@ -137,3 +141,135 @@ instance FromCBOR RelayAccessPoint where
137141
_ -> fail $ "Unrecognized RelayAccessPoint tag: " <> show constructorTag
138142
where
139143
decodePort = fromIntegral @Int <$> fromCBOR
144+
145+
146+
-- | A Relay as registered on the ledger.
147+
--
148+
-- The only difference with `RelayAccessPoint` is that
149+
-- `LedgerRelayAccessSRVDomain` is not prefixed, as required by CIP#0155.
150+
--
151+
data LedgerRelayAccessPoint =
152+
LedgerRelayAccessDomain !DNS.Domain !Socket.PortNumber
153+
| LedgerRelayAccessSRVDomain !DNS.Domain
154+
-- ^ SRV domain as registered on the ledger
155+
| LedgerRelayAccessAddress !IP.IP !Socket.PortNumber
156+
deriving (Eq, Ord)
157+
158+
instance Show LedgerRelayAccessPoint where
159+
show (LedgerRelayAccessDomain domain port) =
160+
"LedgerRelayAccessDomain " ++ show domain ++ " " ++ show port
161+
show (LedgerRelayAccessSRVDomain domain) =
162+
"LedgerRelayAccessSRVDomain " ++ show domain
163+
show (LedgerRelayAccessAddress ip port) =
164+
"RelayAccessAddress \"" ++ show ip ++ "\" " ++ show port
165+
166+
-- 'IP' nor 'IPv6' is strict, 'IPv4' is strict only because it's a newtype for
167+
-- a primitive type ('Word32').
168+
--
169+
instance NFData LedgerRelayAccessPoint where
170+
rnf (LedgerRelayAccessDomain !_domain !_port) = ()
171+
rnf (LedgerRelayAccessSRVDomain !_domain) = ()
172+
rnf (LedgerRelayAccessAddress ip !_port) =
173+
case ip of
174+
IP.IPv4 ipv4 -> rnf (IP.fromIPv4w ipv4)
175+
IP.IPv6 ipv6 -> rnf (IP.fromIPv6w ipv6)
176+
177+
instance FromJSON LedgerRelayAccessPoint where
178+
parseJSON = withObject "RelayAccessPoint" $ \o -> do
179+
addr <- encodeUtf8 <$> o .: "address"
180+
let res = flip parseMaybe o $ const do
181+
port <- o .: "port"
182+
return (toRelayAccessPoint addr port)
183+
case res of
184+
Nothing -> return $ LedgerRelayAccessSRVDomain (fullyQualified addr)
185+
Just rap -> return rap
186+
187+
where
188+
toRelayAccessPoint :: DNS.Domain -> Int -> LedgerRelayAccessPoint
189+
toRelayAccessPoint address port =
190+
case readMaybe (unpack address) of
191+
Nothing -> LedgerRelayAccessDomain (fullyQualified address) (fromIntegral port)
192+
Just addr -> LedgerRelayAccessAddress addr (fromIntegral port)
193+
fullyQualified = \case
194+
domain | Just (_, '.') <- unsnoc domain -> domain
195+
| otherwise -> domain `snoc` '.'
196+
197+
instance ToJSON LedgerRelayAccessPoint where
198+
toJSON (LedgerRelayAccessDomain addr port) =
199+
object
200+
[ "address" .= decodeUtf8 addr
201+
, "port" .= (fromIntegral port :: Int)
202+
]
203+
toJSON (LedgerRelayAccessSRVDomain domain) =
204+
object
205+
[ "address" .= decodeUtf8 domain
206+
]
207+
toJSON (LedgerRelayAccessAddress ip port) =
208+
object
209+
[ "address" .= Text.pack (show ip)
210+
, "port" .= (fromIntegral port :: Int)
211+
]
212+
213+
instance ToCBOR LedgerRelayAccessPoint where
214+
toCBOR rap = case rap of
215+
LedgerRelayAccessDomain domain port ->
216+
Codec.encodeListLen 3
217+
<> Codec.encodeWord8 0
218+
<> toCBOR domain
219+
<> serialise' port
220+
LedgerRelayAccessAddress (IP.IPv4 ipv4) port ->
221+
Codec.encodeListLen 3
222+
<> Codec.encodeWord8 1
223+
<> toCBOR (IP.fromIPv4 ipv4)
224+
<> serialise' port
225+
LedgerRelayAccessAddress (IP.IPv6 ip6) port ->
226+
Codec.encodeListLen 3
227+
<> Codec.encodeWord8 2
228+
<> toCBOR (IP.fromIPv6 ip6)
229+
<> serialise' port
230+
LedgerRelayAccessSRVDomain domain ->
231+
Codec.encodeListLen 2
232+
<> Codec.encodeWord8 3
233+
<> toCBOR domain
234+
where
235+
serialise' = toCBOR . toInteger
236+
237+
instance FromCBOR LedgerRelayAccessPoint where
238+
fromCBOR = do
239+
listLen <- Codec.decodeListLen
240+
constructorTag <- Codec.decodeWord8
241+
unless ( listLen == 3
242+
|| (listLen == 2 && constructorTag == 3))
243+
$ fail $ "Unrecognized LedgerRelayAccessPoint list length "
244+
<> show listLen <> "for constructor tag "
245+
<> show constructorTag
246+
case constructorTag of
247+
0 -> do
248+
LedgerRelayAccessDomain <$> fromCBOR <*> decodePort
249+
1 -> do
250+
let ip4 = IP.IPv4 . IP.toIPv4 <$> fromCBOR
251+
LedgerRelayAccessAddress <$> ip4 <*> decodePort
252+
2 -> do
253+
let ip6 = IP.IPv6 . IP.toIPv6 <$> fromCBOR
254+
LedgerRelayAccessAddress <$> ip6 <*> decodePort
255+
3 -> do
256+
LedgerRelayAccessSRVDomain <$> fromCBOR
257+
_ -> fail $ "Unrecognized LedgerRelayAccessPoint tag: " <> show constructorTag
258+
where
259+
decodePort = fromIntegral @Int <$> fromCBOR
260+
261+
262+
-- | Type of a DNS SRV prefix as defined by CIP#0155
263+
--
264+
type SRVPrefix = DNS.Domain
265+
266+
prefixLedgerRelayAccessPoint
267+
:: SRVPrefix
268+
-> LedgerRelayAccessPoint
269+
-> RelayAccessPoint
270+
prefixLedgerRelayAccessPoint _prefix (LedgerRelayAccessDomain domain port)
271+
= RelayAccessDomain domain port
272+
prefixLedgerRelayAccessPoint prefix (LedgerRelayAccessSRVDomain domain)
273+
= RelayAccessSRVDomain (prefix <> "." <> domain)
274+
prefixLedgerRelayAccessPoint _prefix (LedgerRelayAccessAddress ip port)
275+
= RelayAccessAddress ip port

‎ouroboros-network/cardano-diffusion/Cardano/Network/Diffusion.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -183,6 +183,7 @@ run lpci tracerChurnMode localConfig metrics tracers args apps = do
183183
Cardano.Churn.readUseBootstrap = Cardano.LC.readUseBootstrapPeers localConfig,
184184
Cardano.Churn.consensusMode = Cardano.LC.consensusMode localConfig,
185185
Cardano.Churn.tracerChurnMode = tracerChurnMode
186-
}
186+
},
187+
daSRVPrefix = Cardano.LC.srvPrefix
187188
}
188189
args apps

0 commit comments

Comments
 (0)