Skip to content

Commit 1a8f29a

Browse files
qnikstqnikst
committed
Support gov/pparams/v0 namespace
1 parent 4ff0e9f commit 1a8f29a

File tree

7 files changed

+477
-1
lines changed

7 files changed

+477
-1
lines changed

‎libs/cardano-ledger-canonical-state/cardano-ledger-canonical-state.cabal‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -46,14 +46,17 @@ library
4646
Cardano.Ledger.CanonicalState.Namespace.Blocks.V0
4747
Cardano.Ledger.CanonicalState.Namespace.GovCommittee.V0
4848
Cardano.Ledger.CanonicalState.Namespace.GovConstitution.V0
49+
Cardano.Ledger.CanonicalState.Namespace.GovPParams.V0
4950
Cardano.Ledger.CanonicalState.Namespace.UTxO.V0
5051

5152
hs-source-dirs: src
5253
build-depends:
54+
-- cardano-slotting,
5355
base,
5456
base16-bytestring,
5557
bytestring,
5658
cardano-crypto-class,
59+
cardano-data,
5760
cardano-ledger-binary,
5861
cardano-ledger-core,
5962
cborg,
@@ -74,6 +77,9 @@ library conway
7477
base,
7578
cardano-ledger-canonical-state,
7679
cardano-ledger-conway,
80+
cborg,
81+
microlens,
82+
scls-cbor,
7783
scls-core,
7884

7985
library testlib
@@ -112,6 +118,7 @@ test-suite tests
112118
base,
113119
cardano-ledger-canonical-state:{cardano-ledger-canonical-state, conway, testlib},
114120
cardano-ledger-conway,
121+
cardano-ledger-core,
115122
cardano-ledger-core:testlib,
116123
scls-cardano:testlib,
117124
scls-cbor,

‎libs/cardano-ledger-canonical-state/conway/Cardano/Ledger/CanonicalState/Conway.hs‎

Lines changed: 195 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,21 +1,49 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE FlexibleInstances #-}
34
{-# LANGUAGE MultiParamTypeClasses #-}
5+
{-# LANGUAGE OverloadedStrings #-}
6+
{-# LANGUAGE RankNTypes #-}
47
{-# LANGUAGE RecordWildCards #-}
8+
{-# LANGUAGE ScopedTypeVariables #-}
9+
{-# LANGUAGE TypeApplications #-}
510
{-# LANGUAGE TypeFamilies #-}
611
{-# OPTIONS_GHC -Wno-orphans #-}
712

813
module Cardano.Ledger.CanonicalState.Conway (
914
mkCanonicalConstitution,
1015
) where
1116

17+
import Cardano.Ledger.CanonicalState.BasicTypes (
18+
CanonicalCoin (..),
19+
fromCanonicalExUnits,
20+
mkCanonicalExUnits,
21+
)
1222
import Cardano.Ledger.CanonicalState.Namespace
1323
import Cardano.Ledger.CanonicalState.Namespace.GovCommittee.V0 ()
1424
import Cardano.Ledger.CanonicalState.Namespace.GovConstitution.V0
25+
import Cardano.Ledger.CanonicalState.Namespace.GovPParams.V0
1526
import Cardano.Ledger.CanonicalState.Namespace.UTxO.V0
1627
import Cardano.Ledger.Conway (ConwayEra)
28+
import Cardano.Ledger.Conway.Core
1729
import Cardano.Ledger.Conway.Governance (Constitution (..))
30+
import Cardano.Ledger.Conway.PParams
31+
import Cardano.SCLS.CBOR.Canonical (
32+
CanonicalDecoder,
33+
assumeCanonicalDecoder,
34+
assumeCanonicalEncoding,
35+
)
36+
import Cardano.SCLS.CBOR.Canonical.Decoder (
37+
FromCanonicalCBOR (..),
38+
decodeMapLenCanonicalOf,
39+
decodeWordCanonicalOf,
40+
)
41+
import Cardano.SCLS.CBOR.Canonical.Encoder (ToCanonicalCBOR (..), encodeAsMap, mkEncodablePair)
1842
import Cardano.SCLS.NamespaceCodec
43+
import Cardano.SCLS.Versioned (Versioned (..))
44+
import qualified Codec.CBOR.Decoding as D
45+
import qualified Codec.CBOR.Encoding as E
46+
import Lens.Micro
1947

2048
type instance NamespaceEra "blocks/v0" = ConwayEra
2149

@@ -25,9 +53,176 @@ type instance NamespaceEra "utxo/v0" = ConwayEra
2553

2654
type instance NamespaceEra "gov/constitution/v0" = ConwayEra
2755

56+
type instance NamespaceEra "gov/pparams/v0" = ConwayEra
57+
58+
type instance NamespaceEra "utxo/v0" = ConwayEra
59+
2860
instance KnownNamespace "utxo/v0" where
2961
type NamespaceKey "utxo/v0" = UtxoIn
3062
type NamespaceEntry "utxo/v0" = UtxoOut ConwayEra
3163

3264
mkCanonicalConstitution :: Constitution era -> CanonicalConstitution
3365
mkCanonicalConstitution Constitution {..} = CanonicalConstitution {..}
66+
67+
instance ToCanonicalCBOR "gov/pparams/v0" (PParams ConwayEra) where
68+
toCanonicalCBOR v pp =
69+
encodeAsMap
70+
[ mkEncodablePair v (0 :: Int) (pp ^. ppTxFeePerByteL . to (CanonicalCoin . unCoinPerByte))
71+
, mkEncodablePair v (1 :: Int) (pp ^. ppTxFeeFixedCompactL . to (CanonicalCoin))
72+
, mkEncodablePair v (2 :: Int) (pp ^. ppMaxBBSizeL)
73+
, mkEncodablePair v (3 :: Int) (pp ^. ppMaxTxSizeL)
74+
, mkEncodablePair v (4 :: Int) (pp ^. ppMaxBHSizeL)
75+
, mkEncodablePair v (5 :: Int) (pp ^. ppKeyDepositCompactL . to (CanonicalCoin))
76+
, mkEncodablePair v (6 :: Int) (pp ^. ppPoolDepositCompactL . to (CanonicalCoin))
77+
, mkEncodablePair v (7 :: Int) (pp ^. ppEMaxL)
78+
, mkEncodablePair v (8 :: Int) (pp ^. ppNOptL)
79+
, mkEncodablePair v (9 :: Int) (pp ^. ppA0L)
80+
, mkEncodablePair v (10 :: Int) (pp ^. ppRhoL)
81+
, mkEncodablePair v (11 :: Int) (pp ^. ppTauL)
82+
, mkEncodablePair v (14 :: Int) (pp ^. ppProtocolVersionL)
83+
, mkEncodablePair v (16 :: Int) (pp ^. ppMinPoolCostCompactL . to (CanonicalCoin))
84+
, mkEncodablePair v (17 :: Int) (pp ^. ppCoinsPerUTxOByteL . to (CanonicalCoin . unCoinPerByte))
85+
, mkEncodablePair v (18 :: Int) (pp ^. ppCostModelsL)
86+
, mkEncodablePair v (19 :: Int) (pp ^. ppPricesL . to (mkCanonicalPrices))
87+
, mkEncodablePair v (20 :: Int) (pp ^. ppMaxTxExUnitsL . to (mkCanonicalExUnits))
88+
, mkEncodablePair v (21 :: Int) (pp ^. ppMaxBlockExUnitsL . to (mkCanonicalExUnits))
89+
, mkEncodablePair v (22 :: Int) (pp ^. ppMaxValSizeL)
90+
, mkEncodablePair v (23 :: Int) (pp ^. ppCollateralPercentageL)
91+
, mkEncodablePair v (24 :: Int) (pp ^. ppMaxCollateralInputsL)
92+
, mkEncodablePair v (25 :: Int) (pp ^. ppPoolVotingThresholdsL)
93+
, mkEncodablePair v (26 :: Int) (pp ^. ppDRepVotingThresholdsL)
94+
, mkEncodablePair v (27 :: Int) (pp ^. ppCommitteeMinSizeL)
95+
, mkEncodablePair v (28 :: Int) (pp ^. ppCommitteeMaxTermLengthL)
96+
, mkEncodablePair v (29 :: Int) (pp ^. ppGovActionLifetimeL)
97+
, mkEncodablePair v (30 :: Int) (pp ^. ppGovActionDepositCompactL . to (CanonicalCoin))
98+
, mkEncodablePair v (31 :: Int) (pp ^. ppDRepDepositCompactL . to (CanonicalCoin))
99+
, mkEncodablePair v (32 :: Int) (pp ^. ppDRepActivityL)
100+
, mkEncodablePair v (33 :: Int) (pp ^. ppMinFeeRefScriptCostPerByteL)
101+
]
102+
103+
instance FromCanonicalCBOR "gov/pparams/v0" (PParams ConwayEra) where
104+
fromCanonicalCBOR = do
105+
decodeMapLenCanonicalOf 30
106+
txFeePerByte <- decodeField @"gov/pparams/v0" @CanonicalCoin 0
107+
txFeeFixedCompact <- decodeField @"gov/pparams/v0" @CanonicalCoin 1
108+
maxBBSize <- decodeField @"gov/pparams/v0" 2
109+
maxTxSize <- decodeField @"gov/pparams/v0" 3
110+
maxBHSize <- decodeField @"gov/pparams/v0" 4
111+
keyDepositCompact <- decodeField @"gov/pparams/v0" @CanonicalCoin 5
112+
poolDepositCompact <- decodeField @"gov/pparams/v0" @CanonicalCoin 6
113+
eMax <- decodeField @"gov/pparams/v0" 7
114+
nOpt <- decodeField @"gov/pparams/v0" 8
115+
a0 <- decodeField @"gov/pparams/v0" 9
116+
rho <- decodeField @"gov/pparams/v0" 10
117+
tau <- decodeField @"gov/pparams/v0" 11
118+
protVer <- decodeField @"gov/pparams/v0" 14
119+
minPoolCostCompact <- decodeField @"gov/pparams/v0" @CanonicalCoin 16
120+
coinsPerUTxOByte <- decodeField @"gov/pparams/v0" @CanonicalCoin 17
121+
costModels <- decodeField @"gov/pparams/v0" 18
122+
prices <- decodeField @"gov/pparams/v0" 19
123+
maxTxExUnits <- decodeField @"gov/pparams/v0" 20
124+
maxBlockExUnits <- decodeField @"gov/pparams/v0" 21
125+
maxValSize <- decodeField @"gov/pparams/v0" 22
126+
collateralPercentage <- decodeField @"gov/pparams/v0" 23
127+
maxCollateralInputs <- decodeField @"gov/pparams/v0" 24
128+
poolVotingThresholds <- decodeField @"gov/pparams/v0" 25
129+
dRepVotingThresholds <- decodeField @"gov/pparams/v0" 26
130+
committeeMinSize <- decodeField @"gov/pparams/v0" 27
131+
committeeMaxTermLength <- decodeField @"gov/pparams/v0" 28
132+
govActionLifetime <- decodeField @"gov/pparams/v0" 29
133+
govActionDepositCompact <- decodeField @"gov/pparams/v0" @CanonicalCoin 30
134+
dRepDepositCompact <- decodeField @"gov/pparams/v0" @CanonicalCoin 31
135+
dRepActivity <- decodeField @"gov/pparams/v0" 32
136+
minFeeRefScriptCostPerByte <- decodeField @"gov/pparams/v0" 33
137+
138+
return $
139+
Versioned $
140+
emptyPParams @ConwayEra
141+
& ppTxFeePerByteL .~ CoinPerByte (unCoin txFeePerByte)
142+
& ppTxFeeFixedCompactL .~ unCoin txFeeFixedCompact
143+
& ppMaxBBSizeL .~ maxBBSize
144+
& ppMaxTxSizeL .~ maxTxSize
145+
& ppMaxBHSizeL .~ maxBHSize
146+
& ppKeyDepositCompactL .~ unCoin keyDepositCompact
147+
& ppPoolDepositCompactL .~ unCoin poolDepositCompact
148+
& ppEMaxL .~ eMax
149+
& ppNOptL .~ nOpt
150+
& ppA0L .~ a0
151+
& ppRhoL .~ rho
152+
& ppTauL .~ tau
153+
& ppMinPoolCostCompactL .~ unCoin minPoolCostCompact
154+
& ppCoinsPerUTxOByteL .~ CoinPerByte (unCoin coinsPerUTxOByte)
155+
& ppCostModelsL .~ costModels
156+
& ppPricesL .~ fromCanonicalPrices prices
157+
& ppMaxTxExUnitsL .~ fromCanonicalExUnits maxTxExUnits
158+
& ppMaxBlockExUnitsL .~ fromCanonicalExUnits maxBlockExUnits
159+
& ppMaxValSizeL .~ maxValSize
160+
& ppCollateralPercentageL .~ collateralPercentage
161+
& ppMaxCollateralInputsL .~ maxCollateralInputs
162+
& ppPoolVotingThresholdsL .~ poolVotingThresholds
163+
& ppDRepVotingThresholdsL .~ dRepVotingThresholds
164+
& ppCommitteeMinSizeL .~ committeeMinSize
165+
& ppCommitteeMaxTermLengthL .~ committeeMaxTermLength
166+
& ppGovActionLifetimeL .~ govActionLifetime
167+
& ppGovActionDepositCompactL .~ unCoin govActionDepositCompact
168+
& ppDRepDepositCompactL .~ unCoin dRepDepositCompact
169+
& ppDRepActivityL .~ dRepActivity
170+
& ppMinFeeRefScriptCostPerByteL .~ minFeeRefScriptCostPerByte
171+
& ppProtocolVersionL .~ protVer
172+
173+
decodeField :: forall v a s. FromCanonicalCBOR v a => Word -> CanonicalDecoder s a
174+
decodeField expectedTag = do
175+
decodeWordCanonicalOf expectedTag
176+
unVer <$> fromCanonicalCBOR @v
177+
178+
instance ToCanonicalCBOR "gov/pparams/v0" DRepVotingThresholds where
179+
toCanonicalCBOR v dvt =
180+
assumeCanonicalEncoding (E.encodeListLen 10)
181+
<> toCanonicalCBOR v (dvt ^. dvtMotionNoConfidenceL)
182+
<> toCanonicalCBOR v (dvt ^. dvtCommitteeNormalL)
183+
<> toCanonicalCBOR v (dvt ^. dvtCommitteeNoConfidenceL)
184+
<> toCanonicalCBOR v (dvt ^. dvtUpdateToConstitutionL)
185+
<> toCanonicalCBOR v (dvt ^. dvtHardForkInitiationL)
186+
<> toCanonicalCBOR v (dvt ^. dvtPPNetworkGroupL)
187+
<> toCanonicalCBOR v (dvt ^. dvtPPEconomicGroupL)
188+
<> toCanonicalCBOR v (dvt ^. dvtPPTechnicalGroupL)
189+
<> toCanonicalCBOR v (dvt ^. dvtPPGovGroupL)
190+
<> toCanonicalCBOR v (dvt ^. dvtTreasuryWithdrawalL)
191+
192+
instance FromCanonicalCBOR "gov/pparams/v0" DRepVotingThresholds where
193+
fromCanonicalCBOR = do
194+
assumeCanonicalDecoder $ D.decodeListLenCanonicalOf 10
195+
Versioned dvtMotionNoConfidence <- fromCanonicalCBOR @"gov/pparams/v0"
196+
Versioned dvtCommitteeNormal <- fromCanonicalCBOR @"gov/pparams/v0"
197+
Versioned dvtCommitteeNoConfidence <- fromCanonicalCBOR @"gov/pparams/v0"
198+
Versioned dvtUpdateToConstitution <- fromCanonicalCBOR @"gov/pparams/v0"
199+
Versioned dvtHardForkInitiation <- fromCanonicalCBOR @"gov/pparams/v0"
200+
Versioned dvtPPNetworkGroup <- fromCanonicalCBOR @"gov/pparams/v0"
201+
Versioned dvtPPEconomicGroup <- fromCanonicalCBOR @"gov/pparams/v0"
202+
Versioned dvtPPTechnicalGroup <- fromCanonicalCBOR @"gov/pparams/v0"
203+
Versioned dvtPPGovGroup <- fromCanonicalCBOR @"gov/pparams/v0"
204+
Versioned dvtTreasuryWithdrawal <- fromCanonicalCBOR @"gov/pparams/v0"
205+
return $ Versioned DRepVotingThresholds {..}
206+
207+
instance ToCanonicalCBOR "gov/pparams/v0" PoolVotingThresholds where
208+
toCanonicalCBOR v pvt =
209+
toCanonicalCBOR
210+
v
211+
( pvt ^. pvtMotionNoConfidenceL
212+
, pvt ^. pvtCommitteeNormalL
213+
, pvt ^. pvtCommitteeNoConfidenceL
214+
, pvt ^. pvtHardForkInitiationL
215+
, pvt ^. pvtPPSecurityGroupL
216+
)
217+
218+
instance FromCanonicalCBOR "gov/pparams/v0" PoolVotingThresholds where
219+
fromCanonicalCBOR = do
220+
Versioned
221+
( pvtMotionNoConfidence
222+
, pvtCommitteeNormal
223+
, pvtCommitteeNoConfidence
224+
, pvtHardForkInitiation
225+
, pvtPPSecurityGroup
226+
) <-
227+
fromCanonicalCBOR @"gov/pparams/v0"
228+
return $ Versioned PoolVotingThresholds {..}

‎libs/cardano-ledger-canonical-state/src/Cardano/Ledger/CanonicalState/BasicTypes.hs‎

Lines changed: 74 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -13,22 +13,35 @@
1313
{-# LANGUAGE TypeApplications #-}
1414
{-# LANGUAGE TypeOperators #-}
1515
{-# LANGUAGE UndecidableInstances #-}
16+
{-# LANGUAGE ViewPatterns #-}
1617
{-# OPTIONS_GHC -Wno-orphans #-}
1718

1819
module Cardano.Ledger.CanonicalState.BasicTypes (
1920
OnChain (..),
2021
DecodeOnChain (..),
2122
CanonicalCoin (..),
23+
CanonicalExUnits (..),
24+
mkCanonicalExUnits,
25+
fromCanonicalExUnits,
2226
) where
2327

2428
import qualified Cardano.Crypto.Hash as Hash
25-
import Cardano.Ledger.BaseTypes (Anchor (..), SlotNo (..), StrictMaybe (..))
29+
import Cardano.Ledger.BaseTypes (
30+
Anchor (..),
31+
EpochInterval,
32+
NonNegativeInterval,
33+
ProtVer (..),
34+
SlotNo (..),
35+
StrictMaybe (..),
36+
UnitInterval,
37+
)
2638
import Cardano.Ledger.CanonicalState.LedgerCBOR
2739
import Cardano.Ledger.CanonicalState.Namespace (Era, NamespaceEra)
2840
import Cardano.Ledger.Coin (Coin (..), CompactForm (CompactCoin))
2941
import Cardano.Ledger.Credential (Credential (..))
3042
import Cardano.Ledger.Hashes (KeyHash (..), ScriptHash (..))
3143
import qualified Cardano.Ledger.Hashes as H
44+
import Cardano.Ledger.Plutus.ExUnits (ExUnits (..), ExUnits' (..))
3245
import Cardano.SCLS.CBOR.Canonical (CanonicalDecoder)
3346
import Cardano.SCLS.CBOR.Canonical.Decoder (
3447
FromCanonicalCBOR (..),
@@ -162,3 +175,63 @@ instance (Era era, NamespaceEra v ~ era, Typeable kr) => FromCanonicalCBOR v (Cr
162175
0 -> fmap ScriptHashObj <$> fromCanonicalCBOR @v
163176
1 -> fmap KeyHashObj <$> fromCanonicalCBOR @v
164177
_ -> fail "Invalid Credential tag"
178+
179+
deriving via
180+
LedgerCBOR v UnitInterval
181+
instance
182+
(Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v UnitInterval
183+
184+
deriving via
185+
LedgerCBOR v UnitInterval
186+
instance
187+
(Era era, NamespaceEra v ~ era) => FromCanonicalCBOR v UnitInterval
188+
189+
deriving via
190+
LedgerCBOR v NonNegativeInterval
191+
instance
192+
(Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v NonNegativeInterval
193+
194+
deriving via
195+
LedgerCBOR v NonNegativeInterval
196+
instance
197+
(Era era, NamespaceEra v ~ era) => FromCanonicalCBOR v NonNegativeInterval
198+
199+
deriving via
200+
LedgerCBOR v ProtVer
201+
instance
202+
(Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v ProtVer
203+
204+
deriving via
205+
LedgerCBOR v ProtVer
206+
instance
207+
(Era era, NamespaceEra v ~ era) => FromCanonicalCBOR v ProtVer
208+
209+
deriving via
210+
LedgerCBOR v EpochInterval
211+
instance
212+
(Era era, NamespaceEra v ~ era) => ToCanonicalCBOR v EpochInterval
213+
214+
deriving via
215+
LedgerCBOR v EpochInterval
216+
instance
217+
(Era era, NamespaceEra v ~ era) => FromCanonicalCBOR v EpochInterval
218+
219+
data CanonicalExUnits = CanonicalExUnits
220+
{ exUnitsMem' :: !Natural
221+
, exUnitsSteps' :: !Natural
222+
}
223+
deriving (Eq, Show, Generic)
224+
225+
instance ToCanonicalCBOR v CanonicalExUnits where
226+
toCanonicalCBOR v CanonicalExUnits {..} = toCanonicalCBOR v (exUnitsMem', exUnitsSteps')
227+
228+
instance FromCanonicalCBOR v CanonicalExUnits where
229+
fromCanonicalCBOR = do
230+
Versioned (exUnitsMem', exUnitsSteps') <- fromCanonicalCBOR @v
231+
return $ Versioned CanonicalExUnits {..}
232+
233+
mkCanonicalExUnits :: ExUnits -> CanonicalExUnits
234+
mkCanonicalExUnits (unWrapExUnits -> ExUnits' {..}) = CanonicalExUnits {..}
235+
236+
fromCanonicalExUnits :: CanonicalExUnits -> ExUnits
237+
fromCanonicalExUnits CanonicalExUnits {..} = WrapExUnits ExUnits' {..}

0 commit comments

Comments
 (0)