diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 2d189f6e6a..77187b9b57 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -207,6 +207,7 @@ library internal mtl, network, network-mux, + ordered-containers, ouroboros-consensus ^>=0.22, ouroboros-consensus-cardano ^>=0.21, ouroboros-consensus-diffusion ^>=0.19, @@ -217,6 +218,7 @@ library internal ouroboros-network-protocols, parsec, plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib} ^>=1.37, + pretty-simple, prettyprinter, prettyprinter-ansi-terminal, prettyprinter-configurable ^>=1.36, diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs index 571d6ab402..6a58308f4f 100644 --- a/cardano-api/internal/Cardano/Api/Certificate.hs +++ b/cardano-api/internal/Cardano/Api/Certificate.hs @@ -142,6 +142,8 @@ data Certificate era where deriving instance Eq (Certificate era) +deriving instance Ord (Certificate era) + deriving instance Show (Certificate era) instance Typeable era => HasTypeProxy (Certificate era) where diff --git a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs index 44b6f9f08e..dd8a56b73f 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs @@ -55,6 +55,8 @@ deriving instance Show (ConwayEraOnwards era) deriving instance Eq (ConwayEraOnwards era) +deriving instance Ord (ConwayEraOnwards era) + instance Eon ConwayEraOnwards where inEonForEra no yes = \case ByronEra -> no diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs index 5aead9b370..2535bc79d0 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs @@ -50,6 +50,8 @@ deriving instance Show (ShelleyToBabbageEra era) deriving instance Eq (ShelleyToBabbageEra era) +deriving instance Ord (ShelleyToBabbageEra era) + instance Eon ShelleyToBabbageEra where inEonForEra no yes = \case ByronEra -> no diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 6c52171f8c..c19cd3cc38 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -97,8 +97,12 @@ import Data.Ratio import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) +import qualified Data.Text.Lazy as T import GHC.Exts (IsList (..)) import Lens.Micro ((.~), (^.)) +import Text.Pretty.Simple (pShow) + +import Debug.Trace -- | Type synonym for logs returned by the ledger's @evalTxExUnitsWithLogs@ function. -- for scripts in transactions. @@ -245,10 +249,7 @@ estimateBalancedTxBody -- 1. Subtract certificate and proposal deposits -- from the total available Ada value! -- Page 24 Shelley ledger spec - let certificates = - case txCertificates txbodycontent1 of - TxCertificatesNone -> [] - TxCertificates _ certs _ -> map toShelleyCertificate certs + let certificates = convCertificates sbe $ txCertificates txbodycontent1 proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era)) proposalProcedures = @@ -478,8 +479,12 @@ estimateTransactionKeyWitnessCount length [() | (_, _, BuildTxWith KeyWitness{}) <- withdrawals] _ -> 0 + case txCertificates of - TxCertificates _ _ (BuildTxWith witnesses) -> - length [() | (_, KeyWitness{}) <- witnesses] + TxCertificates _ credWits -> + length + [ () + | (_, BuildTxWith (Just (_, witnesses))) <- toList credWits + , KeyWitness{} <- witnesses + ] _ -> 0 + case txUpdateProposal of TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) -> @@ -1049,34 +1054,85 @@ makeTransactionBodyAutoBalance monoidForEraInEon (toCardanoEra sbe) $ \w -> toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent - txbody0 <- - first TxBodyError - $ createTransactionBody - sbe - $ txbodycontent - & modTxOuts - (<> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone]) - exUnitsMapWithLogs <- - first TxBodyErrorValidityInterval $ - evaluateTransactionExecutionUnits - era - systemstart - history - lpp - utxo - txbody0 - - let exUnitsMap = Map.map (fmap snd) exUnitsMapWithLogs - - exUnitsMap' <- - case Map.mapEither id exUnitsMap of - (failures, exUnitsMap') -> - handleExUnitsErrors - (txScriptValidityToScriptValidity (txScriptValidity txbodycontent)) - failures - exUnitsMap' - - txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent + -- do + -- let TxCertificates _ cs (BuildTxWith ws) = txCertificates txbodycontent + -- traceM $ "\nCerts count: " <> show (length cs) + -- traceM $ "\nCerts wits count: " <> show (length ws) + -- + -- traceM . T.unpack $ "\ntxbc0 ixed certs: " <> pShow [(ix, cert, cred) | (ix, cert, cred, _)<- indexTxCertificates $ txCertificates txbodycontent ] + + txbodycontent1 <- do + txbody0 <- + first TxBodyError + $ createTransactionBody + sbe + $ txbodycontent + & modTxOuts + (<> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone]) + exUnitsMapWithLogs <- + first TxBodyErrorValidityInterval $ + evaluateTransactionExecutionUnits + era + systemstart + history + lpp + utxo + txbody0 + + let exUnitsMap = Map.map (fmap snd) exUnitsMapWithLogs + + exUnitsMap' <- + case Map.mapEither id exUnitsMap of + (failures, exUnitsMap') -> + handleExUnitsErrors + (txScriptValidityToScriptValidity (txScriptValidity txbodycontent)) + failures + exUnitsMap' + + traceM . T.unpack $ "\nExecution units: " <> pShow exUnitsMap' <> "\n" + + txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent + traceM . T.unpack $ + "\ntxbc1 ixed certs: " + <> pShow + [(ix, cert, cred) | (ix, cert, cred, _) <- indexTxCertificates $ txCertificates txbodycontent1] + pure txbodycontent1 + + when False $ do + txbody0' <- + first TxBodyError $ + createTransactionBody + sbe + txbodycontent1 + exUnitsMapWithLogs' <- + first TxBodyErrorValidityInterval $ + evaluateTransactionExecutionUnits + era + systemstart + history + lpp + utxo + txbody0' + + let exUnitsMap1' = Map.map (fmap snd) exUnitsMapWithLogs' + + exUnitsMap'' <- + case Map.mapEither id exUnitsMap1' of + (failures, exUnitsMap_') -> + handleExUnitsErrors + (txScriptValidityToScriptValidity (txScriptValidity txbodycontent)) + failures + exUnitsMap_' + + traceM . T.unpack $ "\nExecution units X2 : " <> pShow exUnitsMap'' <> "\n" + + -- do + -- let TxCertificates _ cs (BuildTxWith ws) = txCertificates txbodycontent1 + -- traceM $ "\nCerts count: " <> show (length cs) + -- traceM $ "\nCerts wits count: " <> show (length ws) + -- traceM . T.unpack $ pShow ws + + -- traceM . T.unpack $ "\ntxbc1 wits: " <> pShow ws <> "\n" -- Make a txbody that we will use for calculating the fees. For the purpose -- of fees we just need to make a txbody of the right size in bytes. We do @@ -1500,17 +1556,28 @@ substituteExecutionUnits :: TxCertificates BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxCertificates BuildTx era) mapScriptWitnessesCertificates TxCertificatesNone = Right TxCertificatesNone - mapScriptWitnessesCertificates txCertificates'@(TxCertificates supported certs _) = + mapScriptWitnessesCertificates txCertificates'@(TxCertificates supported _) = do let mappedScriptWitnesses - :: [(StakeCredential, Either (TxBodyErrorAutoBalance era) (Witness WitCtxStake era))] + :: [ ( Certificate era + , ( StakeCredential + , [ Either + (TxBodyErrorAutoBalance era) + (Witness WitCtxStake era) + ] + ) + ) + ] mappedScriptWitnesses = - [ (stakeCred, witness') - | (ix, _, stakeCred, witness) <- indexTxCertificates txCertificates' - , let witness' = adjustScriptWitness (substituteExecUnits ix) witness + [ (cert, (stakeCred, eWitnesses')) + | (ix, cert, stakeCred, witnesses) <- indexTxCertificates txCertificates' + , let eWitnesses' = adjustScriptWitness (substituteExecUnits ix) <$> witnesses ] - in TxCertificates supported certs . BuildTxWith + in TxCertificates supported . fromList <$> traverse - (\(sCred, eScriptWitness) -> (sCred,) <$> eScriptWitness) + ( \(cert, (sCred, eWitnesses)) -> do + wits <- sequenceA eWitnesses + pure (cert, BuildTxWith $ Just (sCred, wits)) + ) mappedScriptWitnesses mapScriptWitnessesVotes diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index 0ba0c92068..5e05384229 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -565,6 +565,8 @@ data ScriptLanguageInEra lang era where deriving instance Eq (ScriptLanguageInEra lang era) +deriving instance Ord (ScriptLanguageInEra lang era) + deriving instance Show (ScriptLanguageInEra lang era) instance ToJSON (ScriptLanguageInEra lang era) where @@ -742,7 +744,7 @@ data ScriptWitness witctx era where deriving instance Show (ScriptWitness witctx era) --- The GADT in the SimpleScriptWitness constructor requires a custom instance +-- The existential in the SimpleScriptWitness constructor requires a custom instance instance Eq (ScriptWitness witctx era) where (==) (SimpleScriptWitness langInEra script) diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 93dd37f9b9..27416cb922 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -11,6 +11,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -302,6 +303,8 @@ import Data.Functor (($>)) import Data.List (sortBy) import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Ordered.Strict (OMap) +import qualified Data.Map.Ordered.Strict as OMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe @@ -327,6 +330,8 @@ import qualified Text.Parsec as Parsec import Text.Parsec (()) import qualified Text.Parsec.String as Parsec +import Debug.Trace + -- ---------------------------------------------------------------------------- -- Transaction outputs -- @@ -1282,36 +1287,61 @@ indexTxWithdrawals (TxWithdrawals _ withdrawals) = data TxCertificates build era where TxCertificatesNone :: TxCertificates build era + -- | Note the following relationships between the types here: + -- StakeCredential 1--* Certificate 1--* Witness + -- In other words, you can have multiple certificates with the same stake credential and multiple witnesses + -- for a certificate. TxCertificates :: ShelleyBasedEra era - -> [Certificate era] - -> BuildTxWith build [(StakeCredential, Witness WitCtxStake era)] - -- ^ There can be more than one script witness per stake credential + -> OMap + (Certificate era) + ( BuildTxWith + build + (Maybe (StakeCredential, [Witness WitCtxStake era])) + ) -> TxCertificates build era deriving instance Eq (TxCertificates build era) deriving instance Show (TxCertificates build era) --- | Index certificates with witnesses by the order they appear in the list (in the transaction). If there are multiple witnesses for the same stake credential, they will be present multiple times with the same index. --- are multiple witnesses for the credential, there will be multiple entries for +instance Semigroup (TxCertificates build era) where + TxCertificatesNone <> x = x + x <> TxCertificatesNone = x + TxCertificates sbe certs1 <> TxCertificates _ certs2 = + TxCertificates sbe $ OMap.unionWithL merge certs1 certs2 + where + merge + :: Certificate era + -> BuildTxWith + build + (Maybe (StakeCredential, [Witness WitCtxStake era])) + -> BuildTxWith + build + (Maybe (StakeCredential, [Witness WitCtxStake era])) + -> BuildTxWith + build + (Maybe (StakeCredential, [Witness WitCtxStake era])) + merge _ ViewTx ViewTx = ViewTx + merge _ (BuildTxWith mCredWit) (BuildTxWith Nothing) = BuildTxWith mCredWit + merge _ (BuildTxWith Nothing) (BuildTxWith mCredWit) = BuildTxWith mCredWit + merge _ (BuildTxWith (Just (sCred, wits1))) (BuildTxWith (Just (_, wits2))) = + BuildTxWith $ Just (sCred, wits1 <> wits2) + +instance Monoid (TxCertificates build era) where + mempty = TxCertificatesNone + +-- | Index certificates with witnesses by the order they appear in the list (in the transaction). If there +-- are multiple witnesses for the same stake credential, they will be present multiple times with the same index. -- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf indexTxCertificates :: TxCertificates BuildTx era - -> [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)] + -> [(ScriptWitnessIndex, Certificate era, StakeCredential, [Witness WitCtxStake era])] indexTxCertificates TxCertificatesNone = [] -indexTxCertificates (TxCertificates _ certs (BuildTxWith witnesses)) = - [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, wit) - | (ix, cert) <- zip [0 ..] certs - , stakeCred <- maybeToList (selectStakeCredentialWitness cert) - , wit <- findAll stakeCred witnesses +indexTxCertificates (TxCertificates _ certsWits) = + [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, witnesses) + | (ix, (cert, BuildTxWith (Just (stakeCred, witnesses)))) <- zip [0 ..] $ toList certsWits ] - where - findAll needle = map snd . filter ((==) needle . fst) - --- ---------------------------------------------------------------------------- --- Transaction update proposal (era-dependent) --- data TxUpdateProposal era where TxUpdateProposalNone :: TxUpdateProposal era @@ -2537,7 +2567,8 @@ fromLedgerTxCertificates sbe body = let certificates = body ^. L.certsTxBodyL in if null certificates then TxCertificatesNone - else TxCertificates sbe (map (fromShelleyCertificate sbe) $ toList certificates) ViewTx + else + TxCertificates sbe . fromList $ map ((,ViewTx) . fromShelleyCertificate sbe) $ toList certificates maybeFromLedgerTxUpdateProposal :: () @@ -2645,7 +2676,7 @@ convCertificates -> Seq.StrictSeq (Shelley.TxCert (ShelleyLedgerEra era)) convCertificates _ = \case TxCertificatesNone -> Seq.empty - TxCertificates _ cs _ -> fromList (map toShelleyCertificate cs) + TxCertificates _ cs -> fromList . map (toShelleyCertificate . fst) $ toList cs convWithdrawals :: TxWithdrawals build era -> L.Withdrawals StandardCrypto convWithdrawals txWithdrawals = @@ -3602,7 +3633,8 @@ collectTxBodyScriptWitnesses scriptWitnessesCertificates txc = List.nub [ (ix, AnyScriptWitness witness) - | (ix, _, _, ScriptWitness _ witness) <- indexTxCertificates txc + | (ix, _, _, witnesses) <- indexTxCertificates txc + , ScriptWitness _ witness <- witnesses ] scriptWitnessesMinting diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs index 84c58d597f..2952fa8d3e 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs @@ -117,7 +117,8 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote apiScriptWitnesses = [ (ix, AnyScriptWitness witness) - | (ix, _, _, ScriptWitness _ witness) <- indexedTxCerts + | (ix, _, _, wits) <- indexedTxCerts + , ScriptWitness _ witness <- wits ] pure @@ -141,7 +142,8 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote setRefInputs = do let refInputs = [ toShelleyTxIn refInput - | (_, _, _, ScriptWitness _ wit) <- indexedTxCerts + | (_, _, _, wits) <- indexedTxCerts + , ScriptWitness _ wit <- wits , refInput <- maybeToList $ getScriptWitnessReferenceInput wit ] @@ -159,7 +161,8 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote conwayEraOnwardsConstraints conwayOnwards $ (L.bodyTxL . L.votingProceduresTxBodyL) .~ votingProcedures - indexedTxCerts :: [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)] + indexedTxCerts + :: [(ScriptWitnessIndex, Certificate era, StakeCredential, [Witness WitCtxStake era])] indexedTxCerts = indexTxCertificates txCertificates' allWitnesses