Fix missing script proposals in transaction building

cardano-api/cardano-api.cabal

@@ -196,6 +196,7 @@ library internal
     mtl,
     network,
     optparse-applicative-fork,
+    ordered-containers,
     ouroboros-consensus ^>=0.20,
     ouroboros-consensus-cardano ^>=0.18,
     ouroboros-consensus-diffusion ^>=0.17,
@@ -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,
@@ -327,6 +327,7 @@ test-suite cardano-api-test
     hedgehog-quickcheck,
     interpolatedstring-perl6,
     mtl,
+    ordered-containers,
     ouroboros-consensus,
     ouroboros-consensus-cardano,
     ouroboros-consensus-protocol,

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

@@ -20,6 +20,7 @@ import           Cardano.Ledger.Shelley.TxAuxData (Metadatum (..), ShelleyTxAuxD
 
 import qualified Data.Map.Strict as Map
 import           Data.Word (Word64)
+import           GHC.Exts (IsList (..))
 
 import           Test.Gen.Cardano.Api.Typed (genCostModel, genRational)
 
@@ -32,7 +33,7 @@ genMetadata = do
   numberOfIndices <- Gen.integral (Range.linear 1 15)
   let indices = map (\i -> fromIntegral i :: Word64) [1 .. numberOfIndices]
   mData <- Gen.list (Range.singleton numberOfIndices) genMetadatum
-  return . ShelleyTxAuxData . Map.fromList $ zip indices mData
+  return . ShelleyTxAuxData . fromList $ zip indices mData
 
 genMetadatum :: Gen Metadatum
 genMetadatum = do

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

@@ -15,11 +15,11 @@ import qualified Data.Aeson.Key as Aeson
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base16 as Base16
-import qualified Data.Map.Strict as Map
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import           Data.Word (Word64)
+import           GHC.Exts (IsList (..))
 
 import           Hedgehog (Gen)
 import qualified Hedgehog.Gen as Gen
@@ -36,8 +36,7 @@ genJsonForTxMetadata mapping =
     Aeson.object
       <$> Gen.list
         (Range.linear 0 (fromIntegral sz))
-        ( (,)
-            <$> (Aeson.fromString . show <$> Gen.word64 Range.constantBounded)
+        ( ((,) . Aeson.fromString . show <$> Gen.word64 Range.constantBounded)
             <*> genJsonForTxMetadataValue mapping
         )
 
@@ -167,7 +166,7 @@ genJsonForTxMetadataValue TxMetadataJsonDetailedSchema = genJsonValue
 genTxMetadata :: Gen TxMetadata
 genTxMetadata =
   Gen.sized $ \sz ->
-    TxMetadata . Map.fromList
+    TxMetadata . fromList
       <$> Gen.list
         (Range.linear 0 (fromIntegral sz))
         ( (,)

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

@@ -149,17 +149,17 @@ 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           Numeric.Natural (Natural)
 
 import           Test.Gen.Cardano.Api.Era
@@ -175,8 +175,6 @@ import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Gen.QuickCheck as Q
 import qualified Hedgehog.Range as Range
 
-{- HLINT ignore "Reduce duplication" -}
-{- HLINT ignore "Use let" -}
 
 genAddressByron :: Gen (Address ByronAddr)
 genAddressByron =
@@ -321,8 +319,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
@@ -591,7 +588,7 @@ genTxAuxScripts era =
             (genScriptInEra (allegraEraOnwardsToShelleyBasedEra w))
     )
 
-genTxWithdrawals :: CardanoEra era -> Gen (TxWithdrawals BuildTx era)
+genTxWithdrawals :: CardanoEra era -> Gen (TxWithdrawals build era)
 genTxWithdrawals =
   inEonForEra
     (pure TxWithdrawalsNone)
@@ -651,12 +648,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
@@ -683,7 +680,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
@@ -722,7 +719,7 @@ genTxInsCollateral =
           ]
     )
 
-genTxInsReference :: CardanoEra era -> Gen (TxInsReference BuildTx era)
+genTxInsReference :: CardanoEra era -> Gen (TxInsReference era)
 genTxInsReference =
   caseByronToAlonzoOrBabbageEraOnwards
     (const (pure TxInsReferenceNone))
@@ -978,7 +975,7 @@ genProtocolParameters era = do
   protocolParamPoolPledgeInfluence <- genRationalInt64
   protocolParamMonetaryExpansion <- genRational
   protocolParamTreasuryCut <- genRational
-  protocolParamCostModels <- pure mempty
+  let protocolParamCostModels = mempty
   -- TODO: Babbage figure out how to deal with
   -- asymmetric cost model JSON instances
   protocolParamPrices <- Gen.maybe genExecutionUnitPrices
@@ -1126,34 +1123,60 @@ 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 <- fmap Proposal <$> Gen.list (Range.constant 0 10) (genProposal w)
+  let sbe = conwayEraOnwardsToShelleyBasedEra w
+  proposalsWithWitnesses <- fmap fromList . forM proposals $ \proposal ->
+    (proposal,) <$> Gen.maybe (genScriptWitnessForStake sbe)
+  pure $ mkTxProposalProcedures 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
+
+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/Certificate.hs

@@ -97,8 +97,6 @@ import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import           Data.IP (IPv4, IPv6)
 import           Data.Maybe
-import qualified Data.Sequence.Strict as Seq
-import qualified Data.Set as Set
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
@@ -610,10 +608,10 @@ toShelleyPoolParams
             (Ledger.boundRational stakePoolMargin)
       , Ledger.ppRewardAccount = toShelleyStakeAddr stakePoolRewardAccount
       , Ledger.ppOwners =
-          Set.fromList
+          fromList
             [kh | StakeKeyHash kh <- stakePoolOwners]
       , Ledger.ppRelays =
-          Seq.fromList
+          fromList
             (map toShelleyStakePoolRelay stakePoolRelays)
       , Ledger.ppMetadata =
           toShelleyPoolMetadata

cardano-api/internal/Cardano/Api/Convenience/Construction.hs

@@ -32,9 +32,9 @@ import qualified Cardano.Ledger.Keys as L
 import qualified Data.List as List
 import qualified Data.Map.Strict as Map
 import           Data.Set (Set)
-import qualified Data.Set as Set
 import           Data.Text (Text)
 import qualified Data.Text as Text
+import           GHC.Exts (IsList (..))
 
 -- | Construct a balanced transaction.
 -- See Cardano.Api.Convenience.Query.queryStateForBalancedTx for a
@@ -120,7 +120,7 @@ renderNotScriptLockedTxInsError (ScriptLockedTxIns txins) =
 
 notScriptLockedTxIns :: [TxIn] -> UTxO era -> Either ScriptLockedTxInsError ()
 notScriptLockedTxIns collTxIns (UTxO utxo) = do
-  let onlyCollateralUTxOs = Map.restrictKeys utxo $ Set.fromList collTxIns
+  let onlyCollateralUTxOs = Map.restrictKeys utxo $ fromList collTxIns
       scriptLockedTxIns =
         filter (\(_, TxOut aInEra _ _ _) -> not $ isKeyAddress aInEra) $ Map.assocs onlyCollateralUTxOs
   if null scriptLockedTxIns

cardano-api/internal/Cardano/Api/Convenience/Query.hs

@@ -54,9 +54,8 @@ import           Data.Map (Map)
 import qualified Data.Map as Map
 import           Data.Maybe (mapMaybe)
 import           Data.Set (Set)
-import qualified Data.Set as Set
 import           Data.Text (Text)
-import           GHC.Exts (IsString (..))
+import           GHC.Exts (IsList (..), IsString (..))
 
 data QueryConvenienceError
   = AcqFailure AcquiringFailure
@@ -122,12 +121,12 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do
     requireShelleyBasedEra era
       & onNothing (left ByronEraNotSupported)
 
-  let stakeCreds = Set.fromList $ mapMaybe filterUnRegCreds certs
-      drepCreds = Set.fromList $ mapMaybe filterUnRegDRepCreds certs
+  let stakeCreds = fromList $ mapMaybe filterUnRegCreds certs
+      drepCreds = fromList $ mapMaybe filterUnRegDRepCreds certs
 
   -- Query execution
   utxo <-
-    lift (queryUtxo sbe (QueryUTxOByTxIn (Set.fromList allTxIns)))
+    lift (queryUtxo sbe (QueryUTxOByTxIn (fromList allTxIns)))
       & onLeft (left . QceUnsupportedNtcVersion)
       & onLeft (left . QueryEraMismatch)
 

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