Introduce pots/v0 namespace for canonical ledger state

New namespace, that follows the same patterns as utxo and blocks
namespace.

Author: qnikst

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

@@ -37,6 +37,7 @@ library
   exposed-modules:
     Cardano.Ledger.CanonicalState.BasicTypes
     Cardano.Ledger.CanonicalState.Namespace.Blocks.V0
+    Cardano.Ledger.CanonicalState.Namespace.Pots.V0
     Cardano.Ledger.CanonicalState.Namespace.UTxO.V0
 
   hs-source-dirs: src
@@ -50,6 +51,7 @@ library
     scls-cardano,
     scls-cbor,
     scls-core,
+    text,
 
 library conway
   import: warnings
@@ -78,6 +80,7 @@ library testlib
     cardano-ledger-canonical-state:{cardano-ledger-canonical-state, conway},
     cardano-ledger-core,
     cardano-ledger-conway:{testlib},
+    generic-random,
 
 test-suite tests
   import: warnings

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

@@ -6,14 +6,18 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Cardano.Ledger.CanonicalState.BasicTypes (
   OnChain (..),
   DecodeOnChain (..),
+  CanonicalCoin (..),
+  IsCanonicalCoin (..),
 ) where
 
+import Cardano.Ledger.Coin (Coin (..), CompactForm (..))
 import Cardano.SCLS.CBOR.Canonical (CanonicalDecoder)
 import Cardano.SCLS.CBOR.Canonical.Decoder (FromCanonicalCBOR (..))
 import Cardano.SCLS.CBOR.Canonical.Encoder (ToCanonicalCBOR (..))
@@ -55,3 +59,34 @@ instance DecodeOnChain v a => FromCanonicalCBOR v (OnChain a) where
 -- `toPlainDecoder`.
 class DecodeOnChain (v :: Symbol) (a :: Type) where
   decodeOnChain :: BS.ByteString -> CanonicalDecoder s a
+
+-- | Wrapper for the coin type
+newtype CanonicalCoin = CanonicalCoin {unCoin :: Integer}
+  deriving (Eq, Ord, Show, Generic)
+
+-- | We introduce type class here because Coin can be created from multiple types.
+class IsCanonicalCoin a where
+  mkCanonicalCoin :: a -> CanonicalCoin
+  fromCanonicalCoin :: CanonicalCoin -> a
+
+instance IsCanonicalCoin CanonicalCoin where
+  mkCanonicalCoin = id
+  fromCanonicalCoin = id
+
+instance IsCanonicalCoin Coin where
+  mkCanonicalCoin Coin {..} = CanonicalCoin {..}
+  fromCanonicalCoin (CanonicalCoin i) = Coin i
+
+instance IsCanonicalCoin (CompactForm Coin) where
+  mkCanonicalCoin (CompactCoin ci) = CanonicalCoin (fromIntegral ci)
+  fromCanonicalCoin (CanonicalCoin ci) = CompactCoin (fromIntegral ci)
+
+instance IsCanonicalCoin Integer where
+  mkCanonicalCoin = CanonicalCoin
+  fromCanonicalCoin (CanonicalCoin ci) = ci
+
+instance ToCanonicalCBOR v CanonicalCoin where
+  toCanonicalCBOR v (CanonicalCoin ci) = toCanonicalCBOR v ci
+
+instance FromCanonicalCBOR v CanonicalCoin where
+  fromCanonicalCBOR = fmap CanonicalCoin <$> fromCanonicalCBOR

libs/cardano-ledger-canonical-state/src/Cardano/Ledger/CanonicalState/Namespace/Pots/V0.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Cardano.Ledger.CanonicalState.Namespace.Pots.V0 (
+  PotsIn (..),
+  PotsOut (..),
+) where
+
+import Cardano.Ledger.BaseTypes (EpochNo (..))
+import Cardano.Ledger.CanonicalState.BasicTypes (CanonicalCoin (..))
+import Cardano.SCLS.CBOR.Canonical.Decoder (FromCanonicalCBOR (..), decodeMapLenCanonicalOf)
+import Cardano.SCLS.CBOR.Canonical.Encoder (ToCanonicalCBOR (..), encodeAsMap, mkEncodablePair)
+import Cardano.SCLS.Entry.IsKey (IsKey (..))
+import Cardano.SCLS.NamespaceCodec (
+  CanonicalCBOREntryDecoder (..),
+  CanonicalCBOREntryEncoder (..),
+  KnownNamespace (..),
+  namespaceKeySize,
+ )
+import Cardano.SCLS.Versioned (Versioned (..))
+import Data.MemPack.ByteOrdered (packWord64beM, unpackBigEndianM)
+import Data.Proxy (Proxy (..))
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+instance KnownNamespace "pots/v0" where
+  type NamespaceKey "pots/v0" = PotsIn
+  type NamespaceEntry "pots/v0" = PotsOut
+
+newtype PotsIn = PotsIn EpochNo
+  deriving (Eq, Ord, Show)
+
+instance IsKey PotsIn where
+  keySize = namespaceKeySize @"pots/v0"
+  packKeyM (PotsIn (EpochNo epochNo)) = do
+    packWord64beM epochNo
+  unpackKeyM = do
+    epochNo <- unpackBigEndianM
+    return $ PotsIn (EpochNo epochNo)
+
+data PotsOut = PotsOut
+  { poFee :: !CanonicalCoin
+  , poDeposit :: !CanonicalCoin
+  , poDonation :: !CanonicalCoin
+  , poReserves :: !CanonicalCoin
+  , poTreasury :: !CanonicalCoin
+  }
+  deriving (Eq, Show)
+  deriving (Generic)
+
+instance ToCanonicalCBOR "pots/v0" PotsOut where
+  toCanonicalCBOR v PotsOut {..} =
+    encodeAsMap
+      [ mkEncodablePair v ("fee" :: Text) poFee
+      , mkEncodablePair v ("deposit" :: Text) poDeposit
+      , mkEncodablePair v ("donation" :: Text) poDonation
+      , mkEncodablePair v ("reserves" :: Text) poReserves
+      , mkEncodablePair v ("treasury" :: Text) poTreasury
+      ]
+
+instance FromCanonicalCBOR "pots/v0" PotsOut where
+  fromCanonicalCBOR = do
+    decodeMapLenCanonicalOf 5
+    Versioned ("fee" :: Text) <- fromCanonicalCBOR
+    Versioned poFee <- fromCanonicalCBOR
+    Versioned ("deposit" :: Text) <- fromCanonicalCBOR
+    Versioned poDeposit <- fromCanonicalCBOR
+    Versioned ("donation" :: Text) <- fromCanonicalCBOR
+    Versioned poDonation <- fromCanonicalCBOR
+    Versioned ("reserves" :: Text) <- fromCanonicalCBOR
+    Versioned poReserves <- fromCanonicalCBOR
+    Versioned ("treasury" :: Text) <- fromCanonicalCBOR
+    Versioned poTreasury <- fromCanonicalCBOR
+    pure (Versioned PotsOut {..})
+
+instance CanonicalCBOREntryEncoder "pots/v0" PotsOut where
+  encodeEntry n = toCanonicalCBOR (Proxy @"pots/v0") n
+
+instance CanonicalCBOREntryDecoder "pots/v0" PotsOut where
+  decodeEntry = fromCanonicalCBOR

libs/cardano-ledger-canonical-state/test/Test/Cardano/Ledger/CanonicalState/Spec.hs

@@ -9,6 +9,7 @@ module Test.Cardano.Ledger.CanonicalState.Spec (spec) where
 
 import Cardano.Ledger.CanonicalState.Conway ()
 import qualified Cardano.Ledger.CanonicalState.Namespace.Blocks.V0 as Blocks.V0
+import qualified Cardano.Ledger.CanonicalState.Namespace.Pots.V0 as Pots.V0
 import qualified Cardano.Ledger.CanonicalState.Namespace.UTxO.V0 as UTxO.V0
 import Cardano.Ledger.Conway (ConwayEra)
 import Cardano.SCLS.CBOR.Canonical.Encoder (ToCanonicalCBOR (..))
@@ -24,11 +25,15 @@ spec = do
     describe "blocks/v0" $ do
       isCanonical @"blocks/v0" @Blocks.V0.BlockOut
       validateType @"blocks/v0" @Blocks.V0.BlockOut "record_entry"
+    describe "pots/v0" $ do
+      isCanonical @"pots/v0" @Pots.V0.PotsOut
+      validateType @"pots/v0" @Pots.V0.PotsOut "record_entry"
     describe "utxo/v0" $ do
       isCanonical @"utxo/v0" @(UTxO.V0.UtxoOut ConwayEra)
       validateType @"utxo/v0" @(UTxO.V0.UtxoOut ConwayEra) "record_entry"
   describe "namespaces" $ do
     testNS @"blocks/v0"
+    testNS @"pots/v0"
     testNS @"utxo/v0"
 
 isCanonical ::

libs/cardano-ledger-canonical-state/testlib/Test/Cardano/Ledger/CanonicalState/Arbitrary.hs

@@ -7,8 +7,11 @@
 
 module Test.Cardano.Ledger.CanonicalState.Arbitrary () where
 
+import Cardano.Ledger.CanonicalState.BasicTypes (CanonicalCoin (..))
 import Cardano.Ledger.CanonicalState.Conway ()
 import qualified Cardano.Ledger.CanonicalState.Namespace.Blocks.V0 as Blocks.V0
+import qualified Cardano.Ledger.CanonicalState.Namespace.Pots.V0 as Pots.V0
+import Generic.Random (genericArbitraryU)
 import qualified Cardano.Ledger.CanonicalState.Namespace.UTxO.V0 as UtxoOut.V0
 import Cardano.Ledger.Core (Era, EraTxOut, TxOut)
 import Test.Cardano.Ledger.Conway.Arbitrary ()
@@ -21,3 +24,9 @@ instance Arbitrary Blocks.V0.BlockOut where
 
 instance (EraTxOut era, Arbitrary (TxOut era), Era era) => Arbitrary (UtxoOut.V0.UtxoOut era) where
   arbitrary = UtxoOut.V0.mkUtxo <$> arbitrary
+
+instance Arbitrary CanonicalCoin where
+  arbitrary = CanonicalCoin . fromIntegral . getPositive @Integer <$> arbitrary
+
+instance Arbitrary Pots.V0.PotsOut where
+  arbitrary = genericArbitraryU