Skip to content

Commit 47e25d0

Browse files
cootcoot
authored
Merge pull request #5131 from IntersectMBO/coot/srv-compliance-cip155
Compliance with CIP#155
2 parents bf20f51 + 261bd65 commit 47e25d0

File tree

24 files changed

+487
-264
lines changed

24 files changed

+487
-264
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
@@ -88,4 +90,11 @@ diffusionArguments handshakeNtNTracer
8890
, Diffusion.daRequestPublicRootPeers = Nothing
8991
, Diffusion.daPeerChurnGovernor = peerChurnGovernor
9092
, Diffusion.daExtraChurnArgs = ()
93+
, Diffusion.daSRVPrefix = dmqSRVPrefix
9194
}
95+
96+
97+
-- | SRVPrefix as registerd in `CIP#0155`.
98+
--
99+
dmqSRVPrefix :: SRVPrefix
100+
dmqSRVPrefix = "_dmq._mithril._cardano._tcp"

‎docs/network-spec/miniprotocols.tex

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2181,6 +2181,7 @@ \section{Node-to-node protocol}
21812181
\begin{tabular}{l|l}
21822182
\header{version} & \header{description} \\\hline
21832183
\texttt{NodeToNodeV\_14} & No changes, identifies Plomin HF nodes mandatory on mainnet as of 2025.01.29\\
2184+
\texttt{NodeToNodeV\_15} & No changes, identifies nodes which support SRV records\\
21842185
\end{tabular}
21852186
\caption{Node-to-node protocol versions}
21862187
\label{table:node-to-node-protocol-versions}

‎ouroboros-network-api/src/Ouroboros/Network/NodeToNode/Version.hs

Lines changed: 13 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -68,14 +68,18 @@ data NodeToNodeVersion =
6868
-- peer sharing server side and can not reply to requests.
6969
NodeToNodeV_14
7070
-- ^ Plomin HF, mandatory on mainnet as of 2025.01.29
71+
| NodeToNodeV_15
72+
-- ^ SRV support
7173
deriving (Eq, Ord, Enum, Bounded, Show, Generic, NFData)
7274

7375
nodeToNodeVersionCodec :: CodecCBORTerm (Text, Maybe Int) NodeToNodeVersion
7476
nodeToNodeVersionCodec = CodecCBORTerm { encodeTerm, decodeTerm }
7577
where
7678
encodeTerm NodeToNodeV_14 = CBOR.TInt 14
79+
encodeTerm NodeToNodeV_15 = CBOR.TInt 15
7780

7881
decodeTerm (CBOR.TInt 14) = Right NodeToNodeV_14
82+
decodeTerm (CBOR.TInt 15) = Right NodeToNodeV_15
7983
decodeTerm (CBOR.TInt n) = Left ( T.pack "decode NodeToNodeVersion: unknown tag: "
8084
<> T.pack (show n)
8185
, Just n
@@ -140,14 +144,14 @@ instance Queryable NodeToNodeVersionData where
140144

141145
nodeToNodeCodecCBORTerm :: NodeToNodeVersion -> CodecCBORTerm Text NodeToNodeVersionData
142146
nodeToNodeCodecCBORTerm =
143-
\case
144-
NodeToNodeV_14 -> v14
145-
147+
\case
148+
NodeToNodeV_14 -> codec
149+
NodeToNodeV_15 -> codec
146150
where
147-
v14 = CodecCBORTerm { encodeTerm = encodeTerm14, decodeTerm = decodeTerm14 }
151+
codec = CodecCBORTerm { encodeTerm = encodeTerm, decodeTerm = decodeTerm }
148152

149-
encodeTerm14 :: NodeToNodeVersionData -> CBOR.Term
150-
encodeTerm14 NodeToNodeVersionData { networkMagic, diffusionMode, peerSharing, query }
153+
encodeTerm :: NodeToNodeVersionData -> CBOR.Term
154+
encodeTerm NodeToNodeVersionData { networkMagic, diffusionMode, peerSharing, query }
151155
= CBOR.TList
152156
[ CBOR.TInt (fromIntegral $ unNetworkMagic networkMagic)
153157
, CBOR.TBool (case diffusionMode of
@@ -159,8 +163,8 @@ nodeToNodeCodecCBORTerm =
159163
, CBOR.TBool query
160164
]
161165

162-
decodeTerm14 :: CBOR.Term -> Either Text NodeToNodeVersionData
163-
decodeTerm14 (CBOR.TList [CBOR.TInt x, CBOR.TBool diffusionMode, CBOR.TInt peerSharing, CBOR.TBool query])
166+
decodeTerm :: CBOR.Term -> Either Text NodeToNodeVersionData
167+
decodeTerm (CBOR.TList [CBOR.TInt x, CBOR.TBool diffusionMode, CBOR.TInt peerSharing, CBOR.TBool query])
164168
| x >= 0
165169
, x <= 0xffffffff
166170
, Just ps <- case peerSharing of
@@ -180,7 +184,7 @@ nodeToNodeCodecCBORTerm =
180184
= Left $ T.pack $ "networkMagic out of bound: " <> show x
181185
| otherwise -- peerSharing < 0 || peerSharing > 1
182186
= Left $ T.pack $ "peerSharing is out of bound: " <> show peerSharing
183-
decodeTerm14 t
187+
decodeTerm t
184188
= Left $ T.pack $ "unknown encoding: " ++ show t
185189

186190

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

Lines changed: 52 additions & 16 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,22 +91,29 @@ 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
--
90-
migrateLedgerPeerSnapshot :: LedgerPeerSnapshot
91-
-> Maybe (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
92-
migrateLedgerPeerSnapshot (LedgerPeerSnapshotV2 lps) = Just lps
113+
migrateLedgerPeerSnapshot
114+
:: LedgerPeerSnapshot
115+
-> Maybe LedgerPeerSnapshot
116+
migrateLedgerPeerSnapshot snapshot@LedgerPeerSnapshotV2{} = Just snapshot
93117

94118
instance ToJSON LedgerPeerSnapshot where
95119
toJSON (LedgerPeerSnapshotV2 (slot, pools)) =
@@ -105,7 +129,7 @@ instance ToJSON LedgerPeerSnapshot where
105129
instance FromJSON LedgerPeerSnapshot where
106130
parseJSON = withObject "LedgerPeerSnapshot" $ \v -> do
107131
vNum :: Int <- v .: "version"
108-
parsedSnapshot <-
132+
ledgerPeerSnapshot <-
109133
case vNum of
110134
2 -> do
111135
slot <- v .: "slotNo"
@@ -120,9 +144,9 @@ instance FromJSON LedgerPeerSnapshot where
120144

121145
return $ LedgerPeerSnapshotV2 (slot, bigPools')
122146
_ -> fail $ "Network.LedgerPeers.Type: parseJSON: failed to parse unsupported version " <> show vNum
123-
case migrateLedgerPeerSnapshot parsedSnapshot of
124-
Just payload -> return $ LedgerPeerSnapshot payload
125-
Nothing -> fail "Network.LedgerPeers.Type: parseJSON: failed to migrate big ledger peer snapshot"
147+
case migrateLedgerPeerSnapshot ledgerPeerSnapshot of
148+
Just ledgerPeerSnapshot' -> return ledgerPeerSnapshot'
149+
Nothing -> fail "Network.LedgerPeers.Type: parseJSON: failed to migrate big ledger peer snapshot"
126150

127151
-- | cardano-slotting provides its own {To,From}CBOR instances for WithOrigin a
128152
-- but to pin down the encoding for CDDL we provide a wrapper with custom
@@ -198,7 +222,7 @@ newtype PoolStake = PoolStake { unPoolStake :: Rational }
198222
deriving (Eq, Ord, Show)
199223
deriving newtype (Fractional, Num, NFData)
200224

201-
newtype PoolStakeCoded = PoolStakeCoded PoolStake
225+
newtype PoolStakeCoded = PoolStakeCoded { unPoolStakeCoded :: PoolStake }
202226
deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational
203227

204228
-- | The accumulated relative stake of a stake pool, like PoolStake but it also includes the
@@ -208,7 +232,7 @@ newtype AccPoolStake = AccPoolStake { unAccPoolStake :: Rational }
208232
deriving (Eq, Ord, Show)
209233
deriving newtype (Fractional, Num)
210234

211-
newtype AccPoolStakeCoded = AccPoolStakeCoded AccPoolStake
235+
newtype AccPoolStakeCoded = AccPoolStakeCoded { unAccPoolStakeCoded :: AccPoolStake }
212236
deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational
213237

214238
-- | Identifies a peer as coming from ledger or not.
@@ -235,11 +259,23 @@ data IsBigLedgerPeer
235259
--
236260
data LedgerPeersConsensusInterface extraAPI m = LedgerPeersConsensusInterface {
237261
lpGetLatestSlot :: STM m (WithOrigin SlotNo)
238-
, lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty RelayAccessPoint)]
262+
, lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
239263
-- | Extension point so that third party users can add more actions
240264
, lpExtraAPI :: extraAPI
241265
}
242266

267+
getRelayAccessPointsFromLedger
268+
:: MonadSTM m
269+
=> SRVPrefix
270+
-> LedgerPeersConsensusInterface extraAPI m
271+
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
272+
getRelayAccessPointsFromLedger
273+
srvPrefix
274+
LedgerPeersConsensusInterface {lpGetLedgerPeers}
275+
=
276+
fmap (fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix)))) lpGetLedgerPeers
277+
278+
243279
mapExtraAPI :: (a -> b) -> LedgerPeersConsensusInterface a m -> LedgerPeersConsensusInterface b m
244280
mapExtraAPI f lpci@LedgerPeersConsensusInterface{ lpExtraAPI = api } =
245281
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/PeerSharing/Codec.hs

Lines changed: 29 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -28,49 +28,39 @@ decodePortNumber = fromIntegral <$> CBOR.decodeWord16
2828
-- /Invariant:/ not a unix socket address type.
2929
---
3030
encodeRemoteAddress :: NodeToNodeVersion -> SockAddr -> CBOR.Encoding
31-
encodeRemoteAddress =
32-
\case
33-
NodeToNodeV_14 -> sockAddr
34-
35-
where
36-
sockAddr = \case
37-
SockAddrInet pn w -> CBOR.encodeListLen 3
38-
<> CBOR.encodeWord 0
39-
<> CBOR.encodeWord32 w
40-
<> encodePortNumber pn
41-
SockAddrInet6 pn _ (w1, w2, w3, w4) _ -> CBOR.encodeListLen 6
42-
<> CBOR.encodeWord 1
43-
<> CBOR.encodeWord32 w1
44-
<> CBOR.encodeWord32 w2
45-
<> CBOR.encodeWord32 w3
46-
<> CBOR.encodeWord32 w4
47-
<> encodePortNumber pn
48-
SockAddrUnix _ -> error "Should never be encoding a SockAddrUnix!"
31+
encodeRemoteAddress _ = \case
32+
SockAddrInet pn w -> CBOR.encodeListLen 3
33+
<> CBOR.encodeWord 0
34+
<> CBOR.encodeWord32 w
35+
<> encodePortNumber pn
36+
SockAddrInet6 pn _ (w1, w2, w3, w4) _ -> CBOR.encodeListLen 6
37+
<> CBOR.encodeWord 1
38+
<> CBOR.encodeWord32 w1
39+
<> CBOR.encodeWord32 w2
40+
<> CBOR.encodeWord32 w3
41+
<> CBOR.encodeWord32 w4
42+
<> encodePortNumber pn
43+
SockAddrUnix _ -> error "Should never be encoding a SockAddrUnix!"
4944

5045
-- | This decoder should be faithful to the PeerSharing
5146
-- CDDL Specification.
5247
--
5348
-- See the network design document for more details
5449
--
5550
decodeRemoteAddress :: NodeToNodeVersion -> CBOR.Decoder s SockAddr
56-
decodeRemoteAddress =
57-
\case
58-
NodeToNodeV_14 -> decoder14
59-
60-
where
61-
decoder14 = do
62-
_ <- CBOR.decodeListLen
63-
tok <- CBOR.decodeWord
64-
case tok of
65-
0 -> do
66-
w <- CBOR.decodeWord32
67-
pn <- decodePortNumber
68-
return (SockAddrInet pn w)
69-
1 -> do
70-
w1 <- CBOR.decodeWord32
71-
w2 <- CBOR.decodeWord32
72-
w3 <- CBOR.decodeWord32
73-
w4 <- CBOR.decodeWord32
74-
pn <- decodePortNumber
75-
return (SockAddrInet6 pn 0 (w1, w2, w3, w4) 0)
76-
_ -> fail ("Serialise.decode.SockAddr unexpected tok " ++ show tok)
51+
decodeRemoteAddress _ = do
52+
_ <- CBOR.decodeListLen
53+
tok <- CBOR.decodeWord
54+
case tok of
55+
0 -> do
56+
w <- CBOR.decodeWord32
57+
pn <- decodePortNumber
58+
return (SockAddrInet pn w)
59+
1 -> do
60+
w1 <- CBOR.decodeWord32
61+
w2 <- CBOR.decodeWord32
62+
w3 <- CBOR.decodeWord32
63+
w4 <- CBOR.decodeWord32
64+
pn <- decodePortNumber
65+
return (SockAddrInet6 pn 0 (w1, w2, w3, w4) 0)
66+
_ -> fail ("Serialise.decode.SockAddr unexpected tok " ++ show tok)

0 commit comments

Comments
 (0)