Skip to content

Commit 26ecb81

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

File tree

14 files changed

+273
-70
lines changed

14 files changed

+273
-70
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: 35 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@
55
{-# LANGUAGE FlexibleInstances #-}
66
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
77
{-# LANGUAGE LambdaCase #-}
8+
{-# LANGUAGE NamedFieldPuns #-}
89
{-# LANGUAGE OverloadedStrings #-}
910
{-# LANGUAGE PatternSynonyms #-}
1011
{-# LANGUAGE ScopedTypeVariables #-}
@@ -21,13 +22,19 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type
2122
, IsLedgerPeer (..)
2223
, IsBigLedgerPeer (..)
2324
, LedgerPeersConsensusInterface (..)
25+
, getRelayAccessPointsFromLedger
2426
, mapExtraAPI
2527
, UseLedgerPeers (..)
2628
, AfterSlot (..)
2729
, LedgerPeersKind (..)
2830
, LedgerPeerSnapshot (.., LedgerPeerSnapshot)
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,15 @@ 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

5664
-- |Public API to access snapshot data. Currently access to only most recent version is available.
5765
-- Nonetheless, serialisation from the node into JSON is supported for older versions via internal
5866
-- api so that newer CLI can still support older node formats.
5967
--
60-
pattern LedgerPeerSnapshot :: (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
68+
pattern LedgerPeerSnapshot :: (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))])
6169
-> LedgerPeerSnapshot
6270
pattern LedgerPeerSnapshot payload <- LedgerPeerSnapshotV2 payload where
6371
LedgerPeerSnapshot payload = LedgerPeerSnapshotV2 payload
@@ -74,21 +82,27 @@ pattern LedgerPeerSnapshot payload <- LedgerPeerSnapshotV2 payload where
7482
-- The two approximate values should be equal if they were created
7583
-- from the same 'faithful' data.
7684
--
77-
compareLedgerPeerSnapshotApproximate :: LedgerPeerSnapshot
78-
-> LedgerPeerSnapshot
85+
compareLedgerPeerSnapshotApproximate :: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
86+
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
7987
-> Bool
8088
compareLedgerPeerSnapshotApproximate baseline candidate =
8189
case tripIt of
8290
Success candidate' -> candidate' == baseline
8391
Error _ -> False
8492
where
85-
tripIt = fromJSON . toJSON $ candidate
93+
tripIt = fmap (fmap (fmap (first unPoolStakeCoded)))
94+
. fmap (fmap (first unAccPoolStakeCoded))
95+
. fromJSON
96+
. toJSON
97+
. fmap (fmap (first PoolStakeCoded))
98+
. fmap (first AccPoolStakeCoded)
99+
$ candidate
86100

87101
-- | In case the format changes in the future, this function provides a migration functionality
88102
-- when possible.
89103
--
90104
migrateLedgerPeerSnapshot :: LedgerPeerSnapshot
91-
-> Maybe (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
105+
-> Maybe (WithOrigin SlotNo, [(AccPoolStake, (PoolStake, NonEmpty LedgerRelayAccessPoint))])
92106
migrateLedgerPeerSnapshot (LedgerPeerSnapshotV2 lps) = Just lps
93107

94108
instance ToJSON LedgerPeerSnapshot where
@@ -198,7 +212,7 @@ newtype PoolStake = PoolStake { unPoolStake :: Rational }
198212
deriving (Eq, Ord, Show)
199213
deriving newtype (Fractional, Num, NFData)
200214

201-
newtype PoolStakeCoded = PoolStakeCoded PoolStake
215+
newtype PoolStakeCoded = PoolStakeCoded { unPoolStakeCoded :: PoolStake }
202216
deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational
203217

204218
-- | The accumulated relative stake of a stake pool, like PoolStake but it also includes the
@@ -208,7 +222,7 @@ newtype AccPoolStake = AccPoolStake { unAccPoolStake :: Rational }
208222
deriving (Eq, Ord, Show)
209223
deriving newtype (Fractional, Num)
210224

211-
newtype AccPoolStakeCoded = AccPoolStakeCoded AccPoolStake
225+
newtype AccPoolStakeCoded = AccPoolStakeCoded { unAccPoolStakeCoded :: AccPoolStake }
212226
deriving (ToCBOR, FromCBOR, FromJSON, ToJSON) via Rational
213227

214228
-- | Identifies a peer as coming from ledger or not.
@@ -235,11 +249,23 @@ data IsBigLedgerPeer
235249
--
236250
data LedgerPeersConsensusInterface extraAPI m = LedgerPeersConsensusInterface {
237251
lpGetLatestSlot :: STM m (WithOrigin SlotNo)
238-
, lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty RelayAccessPoint)]
252+
, lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
239253
-- | Extension point so that third party users can add more actions
240254
, lpExtraAPI :: extraAPI
241255
}
242256

257+
getRelayAccessPointsFromLedger
258+
:: MonadSTM m
259+
=> SRVPrefix
260+
-> LedgerPeersConsensusInterface extraAPI m
261+
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
262+
getRelayAccessPointsFromLedger
263+
srvPrefix
264+
LedgerPeersConsensusInterface {lpGetLedgerPeers}
265+
=
266+
fmap (fmap (fmap (fmap (prefixLedgerRelayAccessPoint srvPrefix)))) lpGetLedgerPeers
267+
268+
243269
mapExtraAPI :: (a -> b) -> LedgerPeersConsensusInterface a m -> LedgerPeersConsensusInterface b m
244270
mapExtraAPI f lpci@LedgerPeersConsensusInterface{ lpExtraAPI = api } =
245271
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)