Merge pull request #602 from IntersectMBO/mgalazyn/fix/missing-script…

…-proposal-in-transaction-build

Fix missing script proposals in transaction building

cardano-api/cardano-api.cabal

@@ -184,6 +184,7 @@ library internal
     data-default-class,
     deepseq,
     directory,
+    dlist,
     either,
     errors,
     filepath,
@@ -281,7 +282,6 @@ library gen
     cardano-binary >=1.6 && <1.8,
     cardano-crypto-class ^>=2.1.2,
     cardano-crypto-test ^>=1.5,
-    cardano-data,
     cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.8.1,
     cardano-ledger-byron-test >=1.5,
     cardano-ledger-conway:testlib >=1.10.0,

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -86,6 +86,7 @@ module Test.Gen.Cardano.Api.Typed
   , genTxAuxScripts
   , genTxBody
   , genTxBodyContent
+  , genValidTxBody
   , genTxCertificates
   , genTxFee
   , genTxIndex
@@ -149,17 +150,18 @@ import qualified Cardano.Ledger.Core as Ledger
 import           Cardano.Ledger.SafeHash (unsafeMakeSafeHash)
 
 import           Control.Applicative (Alternative (..), optional)
+import           Control.Monad
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Short as SBS
 import           Data.Coerce
 import           Data.Int (Int64)
 import           Data.Maybe
-import           Data.OSet.Strict (OSet)
-import qualified Data.OSet.Strict as OSet
 import           Data.Ratio (Ratio, (%))
 import           Data.String
 import           Data.Word (Word16, Word32, Word64)
+import           GHC.Exts (IsList(..))
+import           GHC.Stack
 import           Numeric.Natural (Natural)
 
 import           Test.Gen.Cardano.Api.Era
@@ -318,8 +320,7 @@ genScriptInEra era =
   Gen.choice
     [ ScriptInEra langInEra <$> genScript lang
     | AnyScriptLanguage lang <- [minBound .. maxBound]
-    , -- TODO: scriptLanguageSupportedInEra should be parameterized on ShelleyBasedEra
-    Just langInEra <- [scriptLanguageSupportedInEra era lang]
+    , Just langInEra <- [scriptLanguageSupportedInEra era lang]
     ]
 
 genScriptHash :: Gen ScriptHash
@@ -447,7 +448,7 @@ genOperationalCertificateIssueCounter :: Gen OperationalCertificateIssueCounter
 genOperationalCertificateIssueCounter = snd <$> genOperationalCertificateWithCounter
 
 genOperationalCertificateWithCounter
-  :: Gen (OperationalCertificate, OperationalCertificateIssueCounter)
+  :: HasCallStack => Gen (OperationalCertificate, OperationalCertificateIssueCounter)
 genOperationalCertificateWithCounter = do
   kesVKey <- genVerificationKey AsKesKey
   stkPoolOrGenDelExtSign <-
@@ -460,7 +461,7 @@ genOperationalCertificateWithCounter = do
   case issueOperationalCertificate kesVKey stkPoolOrGenDelExtSign kesP iCounter of
     -- This case should be impossible as we clearly derive the verification
     -- key from the generated signing key.
-    Left err -> fail $ docToString $ prettyError err
+    Left err -> error $ docToString $ prettyError err
     Right pair -> return pair
  where
   convert
@@ -588,7 +589,7 @@ genTxAuxScripts era =
             (genScriptInEra (allegraEraOnwardsToShelleyBasedEra w))
     )
 
-genTxWithdrawals :: CardanoEra era -> Gen (TxWithdrawals BuildTx era)
+genTxWithdrawals :: CardanoEra era -> Gen (TxWithdrawals build era)
 genTxWithdrawals =
   inEonForEra
     (pure TxWithdrawalsNone)
@@ -648,12 +649,12 @@ genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era)
 genTxMintValue =
   inEonForEra
     (pure TxMintNone)
-    ( \supported ->
-        Gen.choice
-          [ pure TxMintNone
-          , TxMintValue supported <$> genValueForMinting supported <*> return (BuildTxWith mempty)
-          ]
-    )
+    $ \supported ->
+      Gen.choice
+        [ pure TxMintNone
+        -- TODO write a generator for the last parameter of 'TxMintValue' constructor
+        , TxMintValue supported <$> genValueForMinting supported <*> return (pure mempty)
+        ]
 
 genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era)
 genTxBodyContent sbe = do
@@ -680,7 +681,7 @@ genTxBodyContent sbe = do
   txScriptValidity <- genTxScriptValidity era
   txProposalProcedures <- genMaybeFeaturedInEra genProposals era
   txVotingProcedures <- genMaybeFeaturedInEra genVotingProcedures era
-  txCurrentTreasuryValue <- genMaybeFeaturedInEra genCurrentTreasuryValue era
+  txCurrentTreasuryValue <- genMaybeFeaturedInEra (Gen.maybe . genCurrentTreasuryValue) era
   txTreasuryDonation <- genMaybeFeaturedInEra genTreasuryDonation era
   pure $
     TxBodyContent
@@ -719,7 +720,7 @@ genTxInsCollateral =
           ]
     )
 
-genTxInsReference :: CardanoEra era -> Gen (TxInsReference BuildTx era)
+genTxInsReference :: CardanoEra era -> Gen (TxInsReference era)
 genTxInsReference =
   caseByronToAlonzoOrBabbageEraOnwards
     (const (pure TxInsReferenceNone))
@@ -761,23 +762,37 @@ genTxOutByron =
     <*> pure TxOutDatumNone
     <*> pure ReferenceScriptNone
 
-genTxBodyByron :: Gen (L.Annotated L.Tx ByteString)
+-- | Partial! It will throw if the generated transaction body is invalid.
+genTxBodyByron :: HasCallStack => Gen (L.Annotated L.Tx ByteString)
 genTxBodyByron = do
   txIns <-
     map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) <$> Gen.list (Range.constant 1 10) genTxIn
   txOuts <- Gen.list (Range.constant 1 10) genTxOutByron
   case Api.makeByronTransactionBody txIns txOuts of
-    Left err -> fail (displayError err)
+    Left err -> error (displayError err)
     Right txBody -> pure txBody
 
 genWitnessesByron :: Gen [KeyWitness ByronEra]
 genWitnessesByron = Gen.list (Range.constant 1 10) genByronKeyWitness
 
-genTxBody :: ShelleyBasedEra era -> Gen (TxBody era)
+-- | This generator validates generated 'TxBodyContent' and backtracks when the generated body
+-- fails the validation. That also means that it is quite slow.
+genValidTxBody :: ShelleyBasedEra era
+               -> Gen (TxBody era, TxBodyContent BuildTx era) -- ^ validated 'TxBody' and 'TxBodyContent'
+genValidTxBody sbe =
+  Gen.mapMaybe
+    (\content ->
+        either (const Nothing) (Just . (, content)) $
+          createAndValidateTransactionBody sbe content
+    )
+    (genTxBodyContent sbe)
+
+-- | Partial! This function will throw an error when the generated transaction is invalid.
+genTxBody :: HasCallStack => ShelleyBasedEra era -> Gen (TxBody era)
 genTxBody era = do
   res <- Api.createAndValidateTransactionBody era <$> genTxBodyContent era
   case res of
-    Left err -> fail (docToString (prettyError err))
+    Left err -> error (docToString (prettyError err))
     Right txBody -> pure txBody
 
 -- | Generate a 'Featured' for the given 'CardanoEra' with the provided generator.
@@ -800,7 +815,7 @@ genMaybeFeaturedInEra
   -> f (Maybe (Featured eon era a))
 genMaybeFeaturedInEra f =
   inEonForEra (pure Nothing) $ \w ->
-    pure Nothing <|> fmap Just (genFeaturedInEra w (f w))
+    Just <$> genFeaturedInEra w (f w)
 
 genTxScriptValidity :: CardanoEra era -> Gen (TxScriptValidity era)
 genTxScriptValidity =
@@ -818,7 +833,7 @@ genTx
 genTx era =
   makeSignedTransaction
     <$> genWitnesses era
-    <*> genTxBody era
+    <*> (fst <$> genValidTxBody era)
 
 genWitnesses :: ShelleyBasedEra era -> Gen [KeyWitness era]
 genWitnesses sbe = do
@@ -871,16 +886,16 @@ genShelleyBootstrapWitness
 genShelleyBootstrapWitness sbe =
   makeShelleyBootstrapWitness sbe
     <$> genWitnessNetworkIdOrByronAddress
-    <*> genTxBody sbe
+    <*> (fst <$> genValidTxBody sbe)
     <*> genSigningKey AsByronKey
 
 genShelleyKeyWitness
   :: ()
   => ShelleyBasedEra era
   -> Gen (KeyWitness era)
 genShelleyKeyWitness sbe =
-  makeShelleyKeyWitness sbe
-    <$> genTxBody sbe
+  makeShelleyKeyWitness sbe . fst
+    <$> genValidTxBody sbe
     <*> genShelleyWitnessSigningKey
 
 genShelleyWitness
@@ -1123,34 +1138,68 @@ genGovernancePollAnswer =
   genGovernancePollHash =
     GovernancePollHash . mkDummyHash <$> Gen.int (Range.linear 0 10)
 
--- TODO: Left off here. Fix this then get back to incorporating proposal procedure
--- script witnesses in the api and then propagate to the cli
-genProposals :: ConwayEraOnwards era -> Gen (TxProposalProcedures BuildTx era)
-genProposals w =
-  conwayEraOnwardsConstraints w $
-    TxProposalProcedures
-      <$> genTxProposalsOSet w
-      <*> return (BuildTxWith mempty)
-
-genTxProposalsOSet
-  :: ConwayEraOnwards era
-  -> Gen (OSet (L.ProposalProcedure (ShelleyLedgerEra era)))
-genTxProposalsOSet w =
-  conwayEraOnwardsConstraints w $
-    OSet.fromFoldable <$> Gen.list (Range.constant 1 10) (genProposal w)
+genProposals :: Applicative (BuildTxWith build)
+             => ConwayEraOnwards era
+             -> Gen (TxProposalProcedures build era)
+genProposals w = conwayEraOnwardsConstraints w $ do
+  proposals <- Gen.list (Range.constant 0 10) (genProposal w)
+  proposalsToBeWitnessed <- Gen.subsequence proposals
+  -- We're generating also some extra proposals, purposely not included in the proposals list, which results
+  -- in an invalid state of 'TxProposalProcedures'.
+  -- We're doing it for the complete representation of possible values space of TxProposalProcedures.
+  -- Proposal procedures code in cardano-api should handle such invalid values just fine.
+  extraProposals <- Gen.list (Range.constant 0 10) (genProposal w)
+  let sbe = conwayEraOnwardsToShelleyBasedEra w
+  proposalsWithWitnesses <-
+    forM (extraProposals <> proposalsToBeWitnessed) $ \proposal ->
+      (proposal,) <$> genScriptWitnessForStake sbe
+  pure $ TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses)
 
 genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era))
 genProposal w =
   conwayEraOnwardsTestConstraints w Q.arbitrary
 
--- TODO: Generate map of script witnesses
-genVotingProcedures :: ConwayEraOnwards era -> Gen (Api.TxVotingProcedures BuildTx era)
-genVotingProcedures w =
-  conwayEraOnwardsConstraints w $
-    Api.TxVotingProcedures <$> Q.arbitrary <*> return (BuildTxWith mempty)
+genVotingProcedures :: Applicative (BuildTxWith build)
+                    => ConwayEraOnwards era
+                    -> Gen (Api.TxVotingProcedures build era)
+genVotingProcedures w = conwayEraOnwardsConstraints w $ do
+  voters <- Gen.list (Range.constant 0 10) Q.arbitrary
+  let sbe = conwayEraOnwardsToShelleyBasedEra w
+  votersWithWitnesses <- fmap fromList . forM voters $ \voter ->
+    (voter,) <$> genScriptWitnessForStake sbe
+  Api.TxVotingProcedures <$> Q.arbitrary <*> pure (pure votersWithWitnesses)
 
 genCurrentTreasuryValue :: ConwayEraOnwards era -> Gen L.Coin
 genCurrentTreasuryValue _era = Q.arbitrary
 
 genTreasuryDonation :: ConwayEraOnwards era -> Gen L.Coin
 genTreasuryDonation _era = Q.arbitrary
+
+-- | This generator does not generate a valid witness - just a random one.
+genScriptWitnessForStake :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxStake era)
+genScriptWitnessForStake sbe = do
+  ScriptInEra scriptLangInEra script' <- genScriptInEra sbe
+  case script' of
+    SimpleScript simpleScript -> do
+      simpleScriptOrReferenceInput <- Gen.choice
+        [ pure $ SScript simpleScript
+        , SReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash
+        ]
+      pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput
+    PlutusScript plutusScriptVersion' plutusScript -> do
+      plutusScriptOrReferenceInput <- Gen.choice
+        [ pure $ PScript plutusScript
+        , PReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash
+        ]
+      scriptRedeemer <- genHashableScriptData
+      PlutusScriptWitness
+        scriptLangInEra
+        plutusScriptVersion'
+        plutusScriptOrReferenceInput
+        NoScriptDatumForStake
+        scriptRedeemer
+        <$> genExecutionUnits
+
+
+
+

cardano-api/internal/Cardano/Api/Feature.hs

@@ -6,6 +6,7 @@
 
 module Cardano.Api.Feature
   ( Featured (..)
+  , mkFeatured
   , unFeatured
   , asFeaturedInEra
   , asFeaturedInShelleyBasedEra
@@ -31,6 +32,17 @@ deriving instance (Show a, Show (eon era)) => Show (Featured eon era a)
 instance Functor (Featured eon era) where
   fmap f (Featured eon a) = Featured eon (f a)
 
+-- | Create a Featured with automatic witness conjuring
+mkFeatured
+  :: forall eon era a
+   . IsCardanoEra era
+  => Eon eon
+  => a
+  -- ^ a value featured in eon
+  -> Maybe (Featured eon era a)
+  -- ^ 'Just' if era is in eon
+mkFeatured a = asFeaturedInEra a cardanoEra
+
 unFeatured :: Featured eon era a -> a
 unFeatured (Featured _ a) = a
 

cardano-api/internal/Cardano/Api/Fees.hs

@@ -79,14 +79,14 @@ import qualified Cardano.Ledger.Plutus.Language as Plutus
 import qualified Ouroboros.Consensus.HardFork.History as Consensus
 import qualified PlutusLedgerApi.V1 as Plutus
 
-import           Control.Monad (forM_)
+import           Control.Monad
 import           Data.Bifunctor (bimap, first, second)
 import           Data.ByteString.Short (ShortByteString)
 import           Data.Function ((&))
 import qualified Data.List as List
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (catMaybes, fromMaybe, maybeToList)
+import           Data.Maybe
 import qualified Data.OSet.Strict as OSet
 import           Data.Ratio
 import           Data.Set (Set)
@@ -96,8 +96,6 @@ import qualified Data.Text as Text
 import           GHC.Exts (IsList (..))
 import           Lens.Micro ((.~), (^.))
 
-{- HLINT ignore "Redundant return" -}
-
 -- | Type synonym for logs returned by the ledger's @evalTxExUnitsWithLogs@ function.
 -- for scripts in transactions.
 type EvalTxExecutionUnitsLog = [Text]
@@ -233,8 +231,9 @@ estimateBalancedTxBody
 
     let sbe = maryEraOnwardsToShelleyBasedEra w
     txbodycontent1 <-
-      first TxFeeEstimationScriptExecutionError $
-        substituteExecutionUnits exUnitsMap txbodycontent
+      maryEraOnwardsConstraints w $
+        first TxFeeEstimationScriptExecutionError $
+          substituteExecutionUnits exUnitsMap txbodycontent
 
     -- Step 2. We need to calculate the current balance of the tx. The user
     -- must at least provide the total value of the UTxOs they intend to spend
@@ -249,10 +248,8 @@ estimateBalancedTxBody
 
         proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era))
         proposalProcedures =
-          case unFeatured <$> txProposalProcedures txbodycontent1 of
-            Nothing -> OSet.empty
-            Just TxProposalProceduresNone -> OSet.empty
-            Just (TxProposalProcedures procedures _) -> procedures
+          maryEraOnwardsConstraints w $
+            maybe mempty (convProposalProcedures . unFeatured) (txProposalProcedures txbodycontent1)
 
         totalDeposits :: L.Coin
         totalDeposits =
@@ -1577,11 +1574,11 @@ substituteExecutionUnits
     mapScriptWitnessesProposals Nothing = return Nothing
     mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = return Nothing
     mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing
-    mapScriptWitnessesProposals (Just (Featured era (TxProposalProcedures osetProposalProcedures (BuildTxWith sWitMap)))) = do
-      let eSubstitutedExecutionUnits =
+    mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith sWitMap)))) = do
+      let allProposalsList = toList $ convProposalProcedures txpp
+          eSubstitutedExecutionUnits =
             [ (proposal, updatedWitness)
-            | let allProposalsList = toList osetProposalProcedures
-            , (proposal, scriptWitness) <- toList sWitMap
+            | (proposal, scriptWitness) <- toList sWitMap
             , index <- maybeToList $ List.elemIndex proposal allProposalsList
             , let updatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) scriptWitness
             ]