diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 2fbd3c7c4c..f6d4fede01 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -213,6 +213,7 @@ library internal scientific, serialise, small-steps ^>=1.1, + some, sop-core, stm, strict-sop-core, diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index c7fe9d96f5..4ec2b4febb 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 , inEonForShelleyBasedEra @@ -56,8 +55,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 (..)) @@ -232,60 +230,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 4d0a6387cc..855465df70 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs @@ -31,7 +31,9 @@ import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Core as L import Control.Monad (foldM) +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 @@ -156,6 +158,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) + -- | A voter, and the conflicting votes of this voter (i.e. votes with the same governance action identifier) newtype VotesMergingConflict era = VotesMergingConflict diff --git a/cardano-api/internal/Cardano/Api/LedgerState.hs b/cardano-api/internal/Cardano/Api/LedgerState.hs index 4ea2f5d5bd..16ac22ac67 100644 --- a/cardano-api/internal/Cardano/Api/LedgerState.hs +++ b/cardano-api/internal/Cardano/Api/LedgerState.hs @@ -251,7 +251,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 (Consensus.CardanoLedgerState Consensus.StandardCrypto) -- ^ Ledgerstate from an unexpected era @@ -1044,7 +1044,7 @@ getNewEpochState -> Consensus.CardanoLedgerState Consensus.StandardCrypto -> Either LedgerStateError (ShelleyAPI.NewEpochState (ShelleyLedgerEra era)) getNewEpochState era x = do - let err = UnexpectedLedgerState (shelleyBasedEraConstraints era $ AnyShelleyBasedEra era) x + let err = UnexpectedLedgerState (shelleyBasedEraConstraints era $ Some era) x case era of ShelleyBasedEraShelley -> case x of diff --git a/cardano-api/internal/Cardano/Api/Orphans.hs b/cardano-api/internal/Cardano/Api/Orphans.hs index dcac5f67a3..ba57bae482 100644 --- a/cardano-api/internal/Cardano/Api/Orphans.hs +++ b/cardano-api/internal/Cardano/Api/Orphans.hs @@ -93,6 +93,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 d85554f9e1..b1923843c8 100644 --- a/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs +++ b/cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs @@ -61,6 +61,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.Data (Data) import Data.Either.Combinators (mapLeft) import qualified Data.List as List +import Data.Some import Data.Text (Text) import qualified Data.Text as T @@ -264,11 +265,11 @@ deserialiseFromTextEnvelopeCddlAnyOf types teCddl = Left (TextEnvelopeCddlTypeError expectedTypes actualType) Just (FromCDDLTx ttoken f) -> do - AnyShelleyBasedEra era <- cddlTypeToEra ttoken + Some era <- cddlTypeToEra ttoken f . InAnyShelleyBasedEra era <$> mapLeft textEnvelopeErrorToTextEnvelopeCddlError (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 @@ -284,26 +285,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 46f22bfcd1..d5ed1e19b5 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -85,7 +85,6 @@ module Cardano.Api ( ShelleyBasedEra(..), IsShelleyBasedEra(..), - AnyShelleyBasedEra(..), InAnyShelleyBasedEra(..), inAnyShelleyBasedEra, shelleyBasedEraConstraints, 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 f12610a875..76c9c192d3 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 (toCardanoEra 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 (toCardanoEra sbe)) + toJSON (Some sbe) === toJSON (anyCardanoEra (toCardanoEra 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 efe1d080b0..0c32661a43 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 @@ -31,19 +31,19 @@ import Test.Tasty.Hedgehog (testProperty) 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 @@ -170,13 +170,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)