From c053cedfc0881f12db189d932b85647ad5eb7d99 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 26 Jun 2023 13:52:58 -0400 Subject: [PATCH] Trying to cheat --- .../Api/Governance/Actions/VotingProcedure.hs | 74 +++++++++++++------ cardano-api/internal/Cardano/Api/TxBody.hs | 2 +- cardano-api/internal/Cardano/Api/Utils.hs | 29 ++++---- 3 files changed, 68 insertions(+), 37 deletions(-) diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs index bd66c876b6..1b59c9fbea 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs @@ -1,29 +1,32 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Cardano.Api.Governance.Actions.VotingProcedure where import Cardano.Api.Address import Cardano.Api.Eras +import Cardano.Api.HasTypeProxy import Cardano.Api.Script +import Cardano.Api.SerialiseCBOR +import Cardano.Api.SerialiseTextEnvelope import Cardano.Api.TxIn import Cardano.Api.Utils -import qualified Cardano.Binary as CBOR import qualified Cardano.Ledger.BaseTypes as Ledger +import qualified Cardano.Ledger.Binary.Plain as Plain import qualified Cardano.Ledger.Conway.Governance as Gov import Cardano.Ledger.Core (EraCrypto) import qualified Cardano.Ledger.Credential as Ledger -import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.Keys import qualified Cardano.Ledger.TxIn as Ledger -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString.Lazy (ByteString) import Data.Maybe.Strict @@ -104,35 +107,42 @@ toVote No = Gov.VoteNo toVote Yes = Gov.VoteYes toVote Abst = Gov.Abstain +--toVotingCredential' +-- :: ShelleyBasedEra era +-- -> StakeCredential +-- -> Either CBOR.DecoderError (Ledger.Credential 'Voting (ShelleyLedgerEra era)) +--toVotingCredential' sbe (StakeCredentialByKey (StakeKeyHash kh)) = do +-- let cbor = CBOR.serialize kh +-- obtainEraCryptoConstraints sbe $ eraDecodeVotingCredential sbe $ BS.toStrict cbor +-- +--toVotingCredential' sbe (StakeCredentialByScript (ScriptHash sh)) = do +-- let cbor = CBOR.serialize sh +-- obtainEraCryptoConstraints sbe $ eraDecodeVotingCredential sbe $ BS.toStrict cbor toVotingCredential - :: Crypto (ShelleyLedgerEra era) - => ShelleyBasedEra era + :: ShelleyBasedEra era -> StakeCredential - -> Either CBOR.DecoderError (Ledger.Credential 'Voting (ShelleyLedgerEra era)) + -> Either Plain.DecoderError (VotingCredential (ShelleyLedgerEra era)) toVotingCredential sbe (StakeCredentialByKey (StakeKeyHash kh)) = do - let cbor = CBOR.serialize kh - eraDecodeVotingCredential sbe $ BS.toStrict cbor + let cbor = Plain.serialize kh + eraDecodeVotingCredential sbe cbor - -- coerceKeyRole $ Ledger.KeyHashObj kh toVotingCredential sbe (StakeCredentialByScript (ScriptHash sh)) = do - let cbor = CBOR.serialize sh - eraDecodeVotingCredential sbe $ BS.toStrict cbor + let cbor = Plain.serialize sh + eraDecodeVotingCredential sbe cbor -- TODO: Conway era -- This is a hack. data StakeCredential in cardano-api is not parameterized by era, it defaults to StandardCrypto. -- However VotingProcedure is parameterized on era so we need to figure out a way to reconcile this. eraDecodeVotingCredential - :: Crypto (ShelleyLedgerEra era) - => ShelleyBasedEra era + :: ShelleyBasedEra era -> ByteString - -> Either CBOR.DecoderError (Ledger.Credential 'Voting (ShelleyLedgerEra era)) -eraDecodeVotingCredential _ bs = - case CBOR.decodeFull' bs of + -> Either Plain.DecoderError (VotingCredential (ShelleyLedgerEra era)) +eraDecodeVotingCredential sbe bs = obtainCryptoConstraints sbe $ + case Plain.decodeFull bs of Left e -> Left e - Right x -> Right x - -- coerceKeyRole $ Ledger.ScriptHashObj (toShelleyScriptHash sh) + Right x -> Right $ VotingCredential x newtype VotingCredential ledgerera @@ -147,13 +157,35 @@ createVotingProcedure -> VoterType -> GovernanceActionIdentifier (ShelleyLedgerEra era) -> VotingCredential (ShelleyLedgerEra era) -- ^ Governance witness credential (ledger checks that you are allowed to vote) - -> Gov.VotingProcedure (ShelleyLedgerEra era) + -> Vote era createVotingProcedure sbe vChoice vt (GovernanceActionIdentifier govActId) (VotingCredential govWitnessCredential) = obtainEraCryptoConstraints sbe - Gov.VotingProcedure + $ Vote $ Gov.VotingProcedure { Gov.vProcGovActionId = govActId , Gov.vProcRole = toVoterRole vt , Gov.vProcRoleKeyHash = govWitnessCredential , Gov.vProcVote = toVote vChoice , Gov.vProcAnchor = SNothing -- TODO: Conway } + +newtype Vote era = Vote { unVote :: Gov.VotingProcedure (ShelleyLedgerEra era) } + deriving (Show, Eq) + + +instance IsShelleyBasedEra era => ToCBOR (Vote era) where + toCBOR (Vote _vp) = undefined + +instance IsShelleyBasedEra era => FromCBOR (Vote era) where + fromCBOR = undefined +instance IsShelleyBasedEra era => SerialiseAsCBOR (Vote era) where + + serialiseToCBOR = undefined + deserialiseFromCBOR = undefined + + +instance IsShelleyBasedEra era => HasTextEnvelope (Vote era) where + textEnvelopeType _ = "Governance vote" + +instance HasTypeProxy era => HasTypeProxy (Vote era) where + data AsType (Vote era) = AsVote + proxyToAsType _ = AsVote diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index f77f4f6c62..77bd696808 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -3634,7 +3634,7 @@ convVotes :: ShelleyBasedEra era -> TxVotes era -> Seq.StrictSeq (Gov.VotingProc convVotes _ TxVotesNone = Seq.empty convVotes sbe (TxVotes _ votes) = Seq.fromList - [ createVotingProcedure sbe voteChoice voterType govActionIdentifier votingCred + [ unVote $ createVotingProcedure sbe voteChoice voterType govActionIdentifier votingCred | (voteChoice, voterType, govActionIdentifier, votingCred) <- votes ] diff --git a/cardano-api/internal/Cardano/Api/Utils.hs b/cardano-api/internal/Cardano/Api/Utils.hs index 5f53f6adeb..9e351105d2 100644 --- a/cardano-api/internal/Cardano/Api/Utils.hs +++ b/cardano-api/internal/Cardano/Api/Utils.hs @@ -30,13 +30,15 @@ module Cardano.Api.Utils , bounded -- ** Constraint solvers + , obtainCryptoConstraints , obtainEraCryptoConstraints ) where import Cardano.Api.Eras import Cardano.Ledger.Core (EraCrypto) -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (Crypto, StandardCrypto) +import Cardano.Ledger.Shelley () import Control.Exception (bracket) import Control.Monad (when) @@ -139,7 +141,7 @@ bounded t = eitherReader $ \s -> do obtainEraCryptoConstraints :: ShelleyBasedEra era - -> (EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto => a) + -> ((EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) => a) -> a obtainEraCryptoConstraints ShelleyBasedEraShelley f = f obtainEraCryptoConstraints ShelleyBasedEraAllegra f = f @@ -148,16 +150,13 @@ obtainEraCryptoConstraints ShelleyBasedEraAlonzo f = f obtainEraCryptoConstraints ShelleyBasedEraBabbage f = f obtainEraCryptoConstraints ShelleyBasedEraConway f = f ---obtainCryptoConstraints --- :: ShelleyBasedEra era --- -> (( ShelleyLedgerEra era ~ StandardShelley --- , Crypto (ShelleyLedgerEra era) --- ) => a --- ) --- -> a ---obtainCryptoConstraints ShelleyBasedEraShelley f = f ---obtainCryptoConstraints ShelleyBasedEraAllegra f = f ---obtainCryptoConstraints ShelleyBasedEraMary f = f ---obtainCryptoConstraints ShelleyBasedEraAlonzo f = f ---obtainCryptoConstraints ShelleyBasedEraBabbage f = f ---obtainCryptoConstraints ShelleyBasedEraConway f = f +obtainCryptoConstraints + :: ShelleyBasedEra era + -> ((Crypto (EraCrypto (ShelleyLedgerEra era))) => a) + -> a +obtainCryptoConstraints ShelleyBasedEraShelley f = f +obtainCryptoConstraints ShelleyBasedEraAllegra f = f +obtainCryptoConstraints ShelleyBasedEraMary f = f +obtainCryptoConstraints ShelleyBasedEraAlonzo f = f +obtainCryptoConstraints ShelleyBasedEraBabbage f = f +obtainCryptoConstraints ShelleyBasedEraConway f = f