Merge pull request #5270 from IntersectMBO/td/intern-vrf-counters

Intern VRF Key Hash counters in CBOR deserializer

Author: lehins

eras/conway/impl/src/Cardano/Ledger/Conway/State/CertState.hs

@@ -51,7 +51,7 @@ import qualified Data.Foldable as F
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import GHC.Generics (Generic)
-import Lens.Micro (Lens', lens, (&), (.~), (^.), _2)
+import Lens.Micro (Lens', lens, (&), (.~), (^.))
 import NoThunks.Class (NoThunks (..))
 
 data ConwayCertState era = ConwayCertState
@@ -167,7 +167,9 @@ instance EraAccounts era => DecShareCBOR (ConwayCertState era) where
     conwayCertVState <-
       decSharePlusLensCBOR $
         lens (\(cs, _, cd, ch) -> (cs, cd, ch)) (\(_, ks, _, _) (cs, cd, ch) -> (cs, ks, cd, ch))
-    conwayCertPState <- decSharePlusLensCBOR _2
+    conwayCertPState <-
+      decSharePlusLensCBOR $
+        lens (\(_, ks, _, _) -> (mempty, ks)) (\(cs, _, cd, ch) (_, ks) -> (cs, ks, cd, ch))
     conwayCertDState <-
       decSharePlusLensCBOR $
         lens (\(cs, ks, cd, _) -> (cs, ks, cd)) (\(_, _, _, ch) (cs, ks, cd) -> (cs, ks, cd, ch))

eras/shelley/impl/src/Cardano/Ledger/Shelley/State/CertState.hs

@@ -42,7 +42,7 @@ import Data.Default (Default (..))
 import qualified Data.Foldable as F
 import qualified Data.Map.Strict as Map
 import GHC.Generics (Generic)
-import Lens.Micro (Lens', lens, (&), (.~), (^.), _2)
+import Lens.Micro (Lens', lens, (&), (.~), (^.))
 import NoThunks.Class (NoThunks (..))
 
 data ShelleyCertState era = ShelleyCertState
@@ -133,7 +133,9 @@ instance EraAccounts era => DecShareCBOR (ShelleyCertState era) where
       , Interns (Credential 'HotCommitteeRole)
       )
   decSharePlusCBOR = decodeRecordNamedT "ShelleyCertState" (const 2) $ do
-    shelleyCertPState <- decSharePlusLensCBOR _2
+    shelleyCertPState <-
+      decSharePlusLensCBOR $
+        lens (\(_, ks, _, _) -> (mempty, ks)) (\(cs, _, cd, ch) (_, ks) -> (cs, ks, cd, ch))
     shelleyCertDState <-
       decSharePlusLensCBOR $
         lens (\(cs, ks, cd, _) -> (cs, ks, cd)) (\(_, _, _, ch) (cs, ks, cd) -> (cs, ks, cd, ch))

libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Sharing.hs

@@ -174,8 +174,8 @@ decShareLensCBOR l = do
   lift $ decShareCBOR (s ^. l)
 
 -- | Using this function it is possible to compose two lenses. One will extract
--- a value and another will used it for placing it into a empty monoid. Here is
--- an example of how a second element of a tuple can be projected on the third
+-- a value and another will place it into an empty monoid.
+-- Here is an example of how a second element of a tuple can be projected on the third
 -- element of a 3-tuple.
 --
 -- > toMemptyLens _3 _2 == lens (\(_, b) -> (mempty, mempty, b)) (\(a, _) (_, _, b) -> (a, b))

libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs

@@ -247,12 +247,13 @@ instance Era era => EncCBOR (PState era) where
     encodeListLen 4 <> encCBOR a <> encCBOR b <> encCBOR c <> encCBOR d
 
 instance DecShareCBOR (PState era) where
-  type Share (PState era) = Interns (KeyHash 'StakePool)
+  type Share (PState era) = (Interns (VRFVerKeyHash 'StakePoolVRF), Interns (KeyHash 'StakePool))
+
   decSharePlusCBOR = decodeRecordNamedT "PState" (const 4) $ do
-    psVRFKeyHashes <- lift decCBOR
-    psStakePools <- decSharePlusLensCBOR (toMemptyLens _1 id)
-    psFutureStakePools <- decSharePlusLensCBOR (toMemptyLens _1 id)
-    psRetiring <- decSharePlusLensCBOR (toMemptyLens _1 id)
+    psVRFKeyHashes <- decSharePlusLensCBOR (toMemptyLens _1 _1)
+    psStakePools <- decSharePlusLensCBOR (toMemptyLens _1 _2)
+    psFutureStakePools <- decSharePlusLensCBOR (toMemptyLens _1 _2)
+    psRetiring <- decSharePlusLensCBOR (toMemptyLens _1 _2)
     pure PState {psVRFKeyHashes, psStakePools, psFutureStakePools, psRetiring}
 
 instance (Era era, DecShareCBOR (PState era)) => DecCBOR (PState era) where