From 3ea4399ff0f17187104f3a9be0154f976fa85cbd Mon Sep 17 00:00:00 2001 From: John Ky Date: Sun, 31 Mar 2024 21:58:04 +1100 Subject: [PATCH] Some experiment --- cardano-api/cardano-api.cabal | 1 + .../Cardano/Api/Eon/ShelleyBasedEra.hs | 106 ++++++++---------- .../Api/Governance/Actions/VotingProcedure.hs | 36 ++++++ .../internal/Cardano/Api/LedgerState.hs | 4 +- cardano-api/internal/Cardano/Api/Orphans.hs | 2 + .../Cardano/Api/SerialiseLedgerCddl.hs | 43 +++---- cardano-api/src/Cardano/Api.hs | 1 - .../cardano-api-test/Test/Cardano/Api/Eras.hs | 8 +- .../Test/Cardano/Api/Typed/CBOR.hs | 10 +- 9 files changed, 121 insertions(+), 90 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 0c93289e45..c58a358551 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -210,6 +210,7 @@ library internal , scientific , serialise , small-steps ^>= 1.0 + , some , sop-core , sop-extras , stm diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index 7a163cb847..f88e16a311 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs @@ -14,7 +14,6 @@ module Cardano.Api.Eon.ShelleyBasedEra ( -- * Shelley-based eras ShelleyBasedEra(..) , IsShelleyBasedEra(..) - , AnyShelleyBasedEra(..) , InAnyShelleyBasedEra(..) , inAnyShelleyBasedEra , shelleyBasedToCardanoEra @@ -57,8 +56,7 @@ import Ouroboros.Consensus.Shelley.Eras as Consensus (StandardAllegra, import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import Control.DeepSeq -import Data.Aeson (FromJSON (..), ToJSON, toJSON, withText) -import qualified Data.Text as Text +import Data.Aeson (ToJSON, toJSON) import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) import Data.Typeable (Typeable) import Text.Pretty (Pretty (..)) @@ -233,60 +231,54 @@ shelleyBasedEraConstraints = \case ShelleyBasedEraBabbage -> id ShelleyBasedEraConway -> id -data AnyShelleyBasedEra where - AnyShelleyBasedEra - :: Typeable era - => ShelleyBasedEra era - -> AnyShelleyBasedEra - -deriving instance Show AnyShelleyBasedEra - -instance Eq AnyShelleyBasedEra where - AnyShelleyBasedEra sbe == AnyShelleyBasedEra sbe' = - case testEquality sbe sbe' of - Nothing -> False - Just Refl -> True -- since no constructors share types - -instance Bounded AnyShelleyBasedEra where - minBound = AnyShelleyBasedEra ShelleyBasedEraShelley - maxBound = AnyShelleyBasedEra ShelleyBasedEraConway - -instance Enum AnyShelleyBasedEra where - enumFrom e = enumFromTo e maxBound - - fromEnum = \case - AnyShelleyBasedEra ShelleyBasedEraShelley -> 1 - AnyShelleyBasedEra ShelleyBasedEraAllegra -> 2 - AnyShelleyBasedEra ShelleyBasedEraMary -> 3 - AnyShelleyBasedEra ShelleyBasedEraAlonzo -> 4 - AnyShelleyBasedEra ShelleyBasedEraBabbage -> 5 - AnyShelleyBasedEra ShelleyBasedEraConway -> 6 - - toEnum = \case - 1 -> AnyShelleyBasedEra ShelleyBasedEraShelley - 2 -> AnyShelleyBasedEra ShelleyBasedEraAllegra - 3 -> AnyShelleyBasedEra ShelleyBasedEraMary - 4 -> AnyShelleyBasedEra ShelleyBasedEraAlonzo - 5 -> AnyShelleyBasedEra ShelleyBasedEraBabbage - 6 -> AnyShelleyBasedEra ShelleyBasedEraConway - n -> - error $ - "AnyShelleyBasedEra.toEnum: " <> show n - <> " does not correspond to any known enumerated era." - -instance ToJSON AnyShelleyBasedEra where - toJSON (AnyShelleyBasedEra sbe) = toJSON sbe - -instance FromJSON AnyShelleyBasedEra where - parseJSON = withText "AnyShelleyBasedEra" - $ \case - "Shelley" -> pure $ AnyShelleyBasedEra ShelleyBasedEraShelley - "Allegra" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAllegra - "Mary" -> pure $ AnyShelleyBasedEra ShelleyBasedEraMary - "Alonzo" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAlonzo - "Babbage" -> pure $ AnyShelleyBasedEra ShelleyBasedEraBabbage - "Conway" -> pure $ AnyShelleyBasedEra ShelleyBasedEraConway - wrong -> fail $ "Failed to parse unknown shelley-based era: " <> Text.unpack wrong +-- deriving instance Show AnyShelleyBasedEra + +-- instance Eq AnyShelleyBasedEra where +-- AnyShelleyBasedEra sbe == AnyShelleyBasedEra sbe' = +-- case testEquality sbe sbe' of +-- Nothing -> False +-- Just Refl -> True -- since no constructors share types + +-- instance Bounded AnyShelleyBasedEra where +-- minBound = AnyShelleyBasedEra ShelleyBasedEraShelley +-- maxBound = AnyShelleyBasedEra ShelleyBasedEraConway + +-- instance Enum AnyShelleyBasedEra where +-- enumFrom e = enumFromTo e maxBound + +-- fromEnum = \case +-- AnyShelleyBasedEra ShelleyBasedEraShelley -> 1 +-- AnyShelleyBasedEra ShelleyBasedEraAllegra -> 2 +-- AnyShelleyBasedEra ShelleyBasedEraMary -> 3 +-- AnyShelleyBasedEra ShelleyBasedEraAlonzo -> 4 +-- AnyShelleyBasedEra ShelleyBasedEraBabbage -> 5 +-- AnyShelleyBasedEra ShelleyBasedEraConway -> 6 + +-- toEnum = \case +-- 1 -> AnyShelleyBasedEra ShelleyBasedEraShelley +-- 2 -> AnyShelleyBasedEra ShelleyBasedEraAllegra +-- 3 -> AnyShelleyBasedEra ShelleyBasedEraMary +-- 4 -> AnyShelleyBasedEra ShelleyBasedEraAlonzo +-- 5 -> AnyShelleyBasedEra ShelleyBasedEraBabbage +-- 6 -> AnyShelleyBasedEra ShelleyBasedEraConway +-- n -> +-- error $ +-- "AnyShelleyBasedEra.toEnum: " <> show n +-- <> " does not correspond to any known enumerated era." + +-- instance ToJSON AnyShelleyBasedEra where +-- toJSON (AnyShelleyBasedEra sbe) = toJSON sbe + +-- instance FromJSON AnyShelleyBasedEra where +-- parseJSON = withText "AnyShelleyBasedEra" +-- $ \case +-- "Shelley" -> pure $ AnyShelleyBasedEra ShelleyBasedEraShelley +-- "Allegra" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAllegra +-- "Mary" -> pure $ AnyShelleyBasedEra ShelleyBasedEraMary +-- "Alonzo" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAlonzo +-- "Babbage" -> pure $ AnyShelleyBasedEra ShelleyBasedEraBabbage +-- "Conway" -> pure $ AnyShelleyBasedEra ShelleyBasedEraConway +-- wrong -> fail $ "Failed to parse unknown shelley-based era: " <> Text.unpack wrong -- | This pairs up some era-dependent type with a 'ShelleyBasedEra' value that -- tells us what era it is, but hides the era type. This is useful when the era diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs index 1a772bc3b9..b441e9da86 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs @@ -30,7 +30,10 @@ import qualified Cardano.Ledger.Api as L import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Core as L +import Data.Map (Map) import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text.Encoding as Text import GHC.Generics @@ -154,6 +157,39 @@ singletonVotingProcedures _ voter govActionId votingProcedure = $ Map.singleton voter $ Map.singleton govActionId votingProcedure +-- | Lax voting procedures that do not enforce any constraints on the voting procedures. +-- In particular this allows for conflicting voting procedures to be merged. +newtype LaxVotingProcedures era = LaxVotingProcedures + { unGovActionIdsByVoter :: + Map + (L.Voter (EraCrypto (ShelleyLedgerEra era))) + (Map + (L.GovActionId (EraCrypto (ShelleyLedgerEra era))) + (Set (L.VotingProcedure (ShelleyLedgerEra era)))) + } + +instance Semigroup (LaxVotingProcedures era) where + LaxVotingProcedures a <> LaxVotingProcedures b = + LaxVotingProcedures $ Map.unionWith (Map.unionWith Set.union) a b + +instance Monoid (LaxVotingProcedures era) where + mempty = LaxVotingProcedures Map.empty + +votingProceduresToLax :: ConwayEraOnwards era -> VotingProcedures era -> LaxVotingProcedures era +votingProceduresToLax eon (VotingProcedures vp) = + conwayEraOnwardsConstraints eon + $ LaxVotingProcedures + $ Map.map (Map.map Set.singleton) + $ L.unVotingProcedures vp + +votingProceduresFromLax :: LaxVotingProcedures era -> (LaxVotingProcedures era, VotingProcedures era) +votingProceduresFromLax (LaxVotingProcedures vp) = + let + votingProcedures = VotingProcedures + $ L.VotingProcedures + $ Map.map (Map.map Set.findMin) vp + in (LaxVotingProcedures vp, votingProcedures) + -- | Right biased merge of Voting procedures. -- TODO Conway we need an alternative version of this function that can report conflicts as it is -- not safe to just throw away votes. diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 54d8e70b9f..e444bb352a 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -254,7 +254,7 @@ data LedgerStateError -- ^ The ledger state condition you were interested in was not met -- prior to the termination epoch. | UnexpectedLedgerState - AnyShelleyBasedEra + (Some ShelleyBasedEra) -- ^ Expected era (NS (Current Consensus.LedgerState) (Consensus.CardanoEras Consensus.StandardCrypto)) -- ^ Ledgerstate from an unexpected era @@ -1052,7 +1052,7 @@ getNewEpochState -> Either LedgerStateError (ShelleyAPI.NewEpochState (ShelleyLedgerEra era)) getNewEpochState era x = do let tip = Telescope.tip $ getHardForkState $ HFC.hardForkLedgerStatePerEra x - err = UnexpectedLedgerState (shelleyBasedEraConstraints era $ AnyShelleyBasedEra era) tip + err = UnexpectedLedgerState (shelleyBasedEraConstraints era $ Some era) tip case era of ShelleyBasedEraShelley -> case tip of diff --git a/cardano-api/internal/Cardano/Api/Orphans.hs b/cardano-api/internal/Cardano/Api/Orphans.hs index 77ab515577..be1cf544f5 100644 --- a/cardano-api/internal/Cardano/Api/Orphans.hs +++ b/cardano-api/internal/Cardano/Api/Orphans.hs @@ -92,6 +92,8 @@ import GHC.Stack (HasCallStack) import GHC.TypeLits import Lens.Micro +deriving instance Ord (L.VotingProcedure era) + deriving instance Generic (L.ApplyTxError era) deriving instance Generic (L.Registration.TooLarge a) deriving instance Generic L.ApplicationNameError diff --git a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs index 7bb799d6f0..1565f9b131 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -60,6 +60,7 @@ import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Lazy as LBS import Data.Data (Data) import qualified Data.List as List +import Data.Some import Data.Text (Text) import qualified Data.Text.Encoding as Text @@ -297,11 +298,11 @@ deserialiseFromTextEnvelopeCddlAnyOf types teCddl = Left (TextEnvelopeCddlTypeError expectedTypes actualType) Just (FromCDDLTx ttoken f) -> do - AnyShelleyBasedEra era <- cddlTypeToEra ttoken + Some era <- cddlTypeToEra ttoken f . InAnyShelleyBasedEra era <$> deserialiseTxLedgerCddl era teCddl Just (FromCDDLWitness ttoken f) -> do - AnyShelleyBasedEra era <- cddlTypeToEra ttoken + Some era <- cddlTypeToEra ttoken f . InAnyShelleyBasedEra era <$> deserialiseWitnessLedgerCddl era teCddl where actualType :: Text @@ -317,26 +318,26 @@ deserialiseFromTextEnvelopeCddlAnyOf types teCddl = -- Parse the text into types because this will increase code readability and -- will make it easier to keep track of the different Cddl descriptions via -- a single sum data type. -cddlTypeToEra :: Text -> Either TextEnvelopeCddlError AnyShelleyBasedEra +cddlTypeToEra :: Text -> Either TextEnvelopeCddlError (Some ShelleyBasedEra) cddlTypeToEra = \case - "Witnessed Tx ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley - "Witnessed Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra - "Witnessed Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary - "Witnessed Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo - "Witnessed Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage - "Witnessed Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway - "Unwitnessed Tx ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley - "Unwitnessed Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra - "Unwitnessed Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary - "Unwitnessed Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo - "Unwitnessed Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage - "Unwitnessed Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway - "TxWitness ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley - "TxWitness AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra - "TxWitness MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary - "TxWitness AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo - "TxWitness BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage - "TxWitness ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway + "Witnessed Tx ShelleyEra" -> return $ Some ShelleyBasedEraShelley + "Witnessed Tx AllegraEra" -> return $ Some ShelleyBasedEraAllegra + "Witnessed Tx MaryEra" -> return $ Some ShelleyBasedEraMary + "Witnessed Tx AlonzoEra" -> return $ Some ShelleyBasedEraAlonzo + "Witnessed Tx BabbageEra" -> return $ Some ShelleyBasedEraBabbage + "Witnessed Tx ConwayEra" -> return $ Some ShelleyBasedEraConway + "Unwitnessed Tx ShelleyEra" -> return $ Some ShelleyBasedEraShelley + "Unwitnessed Tx AllegraEra" -> return $ Some ShelleyBasedEraAllegra + "Unwitnessed Tx MaryEra" -> return $ Some ShelleyBasedEraMary + "Unwitnessed Tx AlonzoEra" -> return $ Some ShelleyBasedEraAlonzo + "Unwitnessed Tx BabbageEra" -> return $ Some ShelleyBasedEraBabbage + "Unwitnessed Tx ConwayEra" -> return $ Some ShelleyBasedEraConway + "TxWitness ShelleyEra" -> return $ Some ShelleyBasedEraShelley + "TxWitness AllegraEra" -> return $ Some ShelleyBasedEraAllegra + "TxWitness MaryEra" -> return $ Some ShelleyBasedEraMary + "TxWitness AlonzoEra" -> return $ Some ShelleyBasedEraAlonzo + "TxWitness BabbageEra" -> return $ Some ShelleyBasedEraBabbage + "TxWitness ConwayEra" -> return $ Some ShelleyBasedEraConway unknownCddlType -> Left $ TextEnvelopeCddlErrUnknownType unknownCddlType readFileTextEnvelopeCddlAnyOf diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 1ed89b321b..73f7323415 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -90,7 +90,6 @@ module Cardano.Api ( ShelleyBasedEra(..), IsShelleyBasedEra(..), - AnyShelleyBasedEra(..), InAnyShelleyBasedEra(..), inAnyShelleyBasedEra, shelleyBasedToCardanoEra, diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs index 162979a003..5475ab1c97 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs @@ -21,7 +21,7 @@ import Test.Tasty.Hedgehog (testProperty) prop_maxBound_CardanoMatchesShelley :: Property prop_maxBound_CardanoMatchesShelley = property $ do AnyCardanoEra era <- forAll $ Gen.element [maxBound] - AnyShelleyBasedEra sbe <- forAll $ Gen.element [maxBound] + Some sbe <- forAll $ Gen.element [maxBound] fromEnum (anyCardanoEra era) === fromEnum (anyCardanoEra (shelleyBasedToCardanoEra sbe)) @@ -30,7 +30,7 @@ prop_maxBound_CardanoMatchesShelley = property $ do prop_roundtrip_JSON_Shelley :: Property prop_roundtrip_JSON_Shelley = property $ do - anySbe <- forAll $ Gen.element $ id @[AnyShelleyBasedEra] [minBound..maxBound] + anySbe <- forAll $ Gen.element $ id @[Some ShelleyBasedEra] [minBound..maxBound] H.tripping anySbe encode decode @@ -42,9 +42,9 @@ prop_roundtrip_JSON_Cardano = property $ do prop_toJSON_CardanoMatchesShelley :: Property prop_toJSON_CardanoMatchesShelley = property $ do - AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound..maxBound] + Some sbe <- forAll $ Gen.element [minBound..maxBound] - toJSON (AnyShelleyBasedEra sbe) === toJSON (anyCardanoEra (shelleyBasedToCardanoEra sbe)) + toJSON (Some sbe) === toJSON (anyCardanoEra (shelleyBasedToCardanoEra sbe)) tests :: TestTree tests = testGroup "Test.Cardano.Api.Json" diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs index 61ca2ddda5..32f9f76cc6 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs @@ -29,19 +29,19 @@ import Test.Tasty.Hedgehog (testProperty) -- we can't derive an Eq instance for Crypto.HD.XPrv prop_roundtrip_txbody_CBOR :: Property prop_roundtrip_txbody_CBOR = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] + Some era <- H.forAll $ Gen.element [minBound..maxBound] x <- H.forAll $ makeSignedTransaction [] <$> genTxBody era H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) prop_roundtrip_tx_CBOR :: Property prop_roundtrip_tx_CBOR = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] + Some era <- H.forAll $ Gen.element [minBound..maxBound] x <- H.forAll $ genTx era shelleyBasedEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) x prop_roundtrip_witness_CBOR :: Property prop_roundtrip_witness_CBOR = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] + Some era <- H.forAll $ Gen.element [minBound..maxBound] x <- H.forAll $ genCardanoKeyWitness era shelleyBasedEraConstraints era $ H.trippingCbor (AsKeyWitness (proxyToAsType Proxy)) x @@ -168,13 +168,13 @@ prop_roundtrip_UpdateProposal_CBOR = H.property $ do prop_roundtrip_Tx_Cddl :: Property prop_roundtrip_Tx_Cddl = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound] + Some era <- H.forAll $ Gen.element [minBound..maxBound] x <- forAll $ genTx era H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) prop_roundtrip_TxWitness_Cddl :: Property prop_roundtrip_TxWitness_Cddl = H.property $ do - AnyShelleyBasedEra sbe <- H.forAll $ Gen.element [minBound..maxBound] + Some sbe <- H.forAll $ Gen.element [minBound..maxBound] x <- forAll $ genShelleyKeyWitness sbe tripping x (serialiseWitnessLedgerCddl sbe) (deserialiseWitnessLedgerCddl sbe)