WIP: Add generators for new API tx-related types

cardano-api/src/Cardano/API.hs

@@ -147,6 +147,7 @@ module Cardano.API (
     -- ** Era-dependent transaction body features
     OnlyAdaSupportedInEra(..),
     MultiAssetSupportedInEra(..),
+    TxFeesExplicitInEra (..),
     ValidityUpperBoundSupportedInEra(..),
     ValidityNoUpperBoundSupportedInEra(..),
     ValidityLowerBoundSupportedInEra(..),

cardano-api/src/Cardano/Api/TxBody.hs

@@ -51,6 +51,7 @@ module Cardano.Api.TxBody (
     -- * Era-dependent transaction body features
     OnlyAdaSupportedInEra(..),
     MultiAssetSupportedInEra(..),
+    TxFeesExplicitInEra (..),
     ValidityUpperBoundSupportedInEra(..),
     ValidityNoUpperBoundSupportedInEra(..),
     ValidityLowerBoundSupportedInEra(..),

cardano-api/src/Cardano/Api/Typed.hs

@@ -170,6 +170,7 @@ module Cardano.Api.Typed (
     -- ** Era-dependent transaction body features
     OnlyAdaSupportedInEra(..),
     MultiAssetSupportedInEra(..),
+    TxFeesExplicitInEra (..),
     ValidityUpperBoundSupportedInEra(..),
     ValidityNoUpperBoundSupportedInEra(..),
     ValidityLowerBoundSupportedInEra(..),
@@ -801,4 +802,3 @@ submitTxToNodeLocal connctInfo tx = do
         pure $ SendMsgSubmitTx tx $ \result -> do
         atomically $ putTMVar resultVar result
         pure (TxSubmission.SendMsgDone ())
-

cardano-api/test/Test/Cardano/Api/MetaData.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Test.Cardano.Api.MetaData
   ( tests
+  , genTxMetadata
   ) where
 
 import           Cardano.Prelude hiding (MetaData)

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

@@ -1,9 +1,13 @@
+{-# LANGUAGE GADTs #-}
+
 module Test.Cardano.Api.Typed.Gen
   ( genAddressByron
   , genAddressShelley
   , genByronKeyWitness
   , genRequiredSig
   , genMofNRequiredSig
+  , genSimpleScript
+  , genSimpleScripts
   , genMultiSigScript
   , genMultiSigScriptAllegra
   , genMultiSigScriptMary
@@ -27,15 +31,17 @@ import           Cardano.Api.Typed
 import           Cardano.Prelude
 
 import           Control.Monad.Fail (fail)
+import qualified Data.Map as Map
 
 import qualified Cardano.Binary as CBOR
 import qualified Cardano.Crypto.Hash as Crypto
 import qualified Cardano.Crypto.Seed as Crypto
 
-import           Hedgehog (Gen)
+import           Hedgehog (Gen, Range)
 import qualified Hedgehog.Gen as Gen
 import qualified Hedgehog.Range as Range
 
+import           Test.Cardano.Api.MetaData (genTxMetadata)
 import           Test.Cardano.Chain.UTxO.Gen (genVKWitness)
 import           Test.Cardano.Crypto.Gen (genProtocolMagicId)
 
@@ -81,6 +87,22 @@ genMofN s = do
  required <- Gen.integral (Range.linear 0 numKeys)
  pure $ RequireMOf required s
 
+-- Script generators for a provided Shelley-based era
+
+genSimpleScript :: ShelleyBasedEra era -> Gen (SimpleScript era)
+genSimpleScript era =
+  case era of
+    ShelleyBasedEraShelley -> genMultiSigScriptShelley
+    ShelleyBasedEraAllegra -> genMultiSigScriptAllegra
+    ShelleyBasedEraMary -> genMultiSigScriptMary
+
+genSimpleScripts :: ShelleyBasedEra era -> Gen [SimpleScript era]
+genSimpleScripts era =
+  case era of
+    ShelleyBasedEraShelley -> genMultiSigScriptsShelley
+    ShelleyBasedEraAllegra -> genMultiSigScriptsAllegra
+    ShelleyBasedEraMary -> genMultiSigScriptsMary
+
 -- Shelley
 
 genMultiSigScriptShelley :: Gen (MultiSigScript ShelleyEra)
@@ -245,13 +267,11 @@ genStakeCredential = do
   return . StakeCredentialByKey $ verificationKeyHash vKey
 
 genTxBodyShelley :: Gen (TxBody ShelleyEra)
-genTxBodyShelley =
-   makeShelleyTransaction
-     <$> genTxExtraContent
-     <*> genTTL
-     <*> genTxFee
-     <*> Gen.list (Range.constant 1 10) genTxIn
-     <*> Gen.list (Range.constant 1 10) genShelleyTxOut
+genTxBodyShelley = do
+  res <- makeTransactionBody <$> genTxBodyContent ShelleyEra
+  case res of
+    Left err -> fail (show err) -- TODO: Render function for TxBodyError
+    Right txBody -> pure txBody
 
 genByronTxOut :: Gen (TxOut ByronEra)
 genByronTxOut =
@@ -272,11 +292,10 @@ genSlotNo = SlotNo <$> Gen.word64 Range.constantBounded
 -- TODO: Should probably have a naive generator that generates no inputs, no outputs etc
 genTxBodyByron :: Gen (TxBody ByronEra)
 genTxBodyByron = do
-  txIns <- Gen.list (Range.constant 1 10) genTxIn
-  txOuts <- Gen.list (Range.constant 1 10) genByronTxOut
-  case makeByronTransaction txIns txOuts of
-    Left err -> panic $ show err
-    Right txBody -> return txBody
+  res <- makeTransactionBody <$> genTxBodyContent ByronEra
+  case res of
+    Left err -> fail (show err)
+    Right txBody -> pure txBody
 
 genTxByron :: Gen (Tx ByronEra)
 genTxByron =
@@ -293,6 +312,54 @@ genTxId = TxId <$> genShelleyHash
 genTxIndex :: Gen TxIx
 genTxIndex = TxIx <$> Gen.word Range.constantBounded
 
+genQuantity :: Gen Quantity
+genQuantity = Quantity <$> Gen.integral (Range.linear 0 5000)
+
+-- TODO: UTF8 bytes or random bytes?
+genAssetName :: Gen AssetName
+genAssetName = AssetName <$> Gen.bytes (Range.singleton 32)
+
+genPolicyId :: Gen PolicyId
+genPolicyId = PolicyId <$> genScriptHash
+
+genAssetId :: Gen AssetId
+genAssetId =
+  Gen.frequency
+    [ (1, pure AdaAssetId)
+    , (9, AssetId <$> genPolicyId <*> genAssetName)
+    ]
+
+genValue :: Gen Value
+genValue = valueFromList <$> Gen.list range genKeyValuePair
+  where
+    range :: Range Int
+    range = Range.constant 1 10
+
+    genKeyValuePair :: Gen (AssetId, Quantity)
+    genKeyValuePair = (,) <$> genAssetId <*> genQuantity
+
+genTxOutValue :: CardanoEra era -> Gen (TxOutValue era)
+genTxOutValue era =
+  case era of
+    ByronEra -> TxOutAdaOnly AdaOnlyInByronEra <$> genLovelace
+    ShelleyEra -> TxOutAdaOnly AdaOnlyInShelleyEra <$> genLovelace
+    AllegraEra -> TxOutAdaOnly AdaOnlyInAllegraEra <$> genLovelace
+    MaryEra -> TxOutValue MultiAssetInMaryEra <$> genValue
+
+genTxOut :: CardanoEra era -> Gen (TxOut era)
+genTxOut era =
+  case era of
+    ByronEra -> genByronTxOut
+    ShelleyEra -> genShelleyTxOut
+    AllegraEra ->
+      TxOut
+        <$> (shelleyAddressInEra <$> genAddressShelley)
+        <*> (TxOutAdaOnly AdaOnlyInAllegraEra <$> genLovelace)
+    MaryEra ->
+      TxOut
+        <$> (shelleyAddressInEra <$> genAddressShelley)
+        <*> genTxOutValue era
+
 genTxShelley :: Gen (Tx ShelleyEra)
 genTxShelley =
   makeSignedTransaction
@@ -305,14 +372,175 @@ genTxShelley =
      keyWits <- Gen.list (Range.constant 0 10) genShelleyKeyWitness
      return $ bsWits ++ keyWits
 
-genTxExtraContent :: Gen TxExtraContent
-genTxExtraContent = return txExtraContentEmpty
-
-genTTL :: Gen TTL
-genTTL = genSlotNo
-
-genTxFee :: Gen TxFee
-genTxFee = genLovelace
+genTtl :: Gen SlotNo
+genTtl = genSlotNo
+
+-- TODO: Accept a range for generating ttl.
+genTxValidityLowerBound :: CardanoEra era -> Gen (TxValidityLowerBound era)
+genTxValidityLowerBound era =
+  case era of
+    ByronEra -> pure TxValidityNoLowerBound
+    ShelleyEra -> pure TxValidityNoLowerBound
+    AllegraEra -> TxValidityLowerBound ValidityLowerBoundInAllegraEra <$> genTtl
+    MaryEra -> TxValidityLowerBound ValidityLowerBoundInMaryEra <$> genTtl
+
+-- TODO: Accept a range for generating ttl.
+genTxValidityUpperBound :: CardanoEra era -> Gen (TxValidityUpperBound era)
+genTxValidityUpperBound era =
+  case era of
+    ByronEra -> pure (TxValidityNoUpperBound ValidityNoUpperBoundInByronEra)
+    ShelleyEra -> TxValidityUpperBound ValidityUpperBoundInShelleyEra <$> genTtl
+    AllegraEra -> TxValidityUpperBound ValidityUpperBoundInAllegraEra <$> genTtl
+    MaryEra -> TxValidityUpperBound ValidityUpperBoundInMaryEra <$> genTtl
+
+genTxValidityRange
+  :: CardanoEra era
+  -> Gen (TxValidityLowerBound era, TxValidityUpperBound era)
+genTxValidityRange era =
+  (,)
+    <$> genTxValidityLowerBound era
+    <*> genTxValidityUpperBound era
+
+genTxMetadataInEra :: CardanoEra era -> Gen (TxMetadataInEra era)
+genTxMetadataInEra era =
+  case era of
+    ByronEra -> pure TxMetadataNone
+    ShelleyEra ->
+      Gen.choice
+        [ pure TxMetadataNone
+        , TxMetadataInEra TxMetadataInShelleyEra <$> genTxMetadata
+        ]
+    AllegraEra ->
+      Gen.choice
+        [ pure TxMetadataNone
+        , TxMetadataInEra TxMetadataInAllegraEra <$> genTxMetadata
+        ]
+    MaryEra ->
+      Gen.choice
+        [ pure TxMetadataNone
+        , TxMetadataInEra TxMetadataInMaryEra <$> genTxMetadata
+        ]
+
+genTxAuxScripts :: CardanoEra era -> Gen (TxAuxScripts era)
+genTxAuxScripts era =
+  case era of
+    ByronEra -> pure TxAuxScriptsNone
+    ShelleyEra -> pure TxAuxScriptsNone
+    AllegraEra ->
+      TxAuxScripts AuxScriptsInAllegraEra
+        <$> (map SimpleScript <$> genSimpleScripts ShelleyBasedEraAllegra)
+    MaryEra ->
+      TxAuxScripts AuxScriptsInMaryEra
+        <$> (map SimpleScript <$> genSimpleScripts ShelleyBasedEraMary)
+
+genTxWithdrawals :: CardanoEra era -> Gen (TxWithdrawals era)
+genTxWithdrawals era =
+  case era of
+    ByronEra -> pure TxWithdrawalsNone
+    ShelleyEra ->
+      Gen.choice
+        [ pure TxWithdrawalsNone
+        , pure (TxWithdrawals WithdrawalsInShelleyEra mempty) -- TODO: Generate withdrawals
+        ]
+    AllegraEra ->
+      Gen.choice
+        [ pure TxWithdrawalsNone
+        , pure (TxWithdrawals WithdrawalsInAllegraEra mempty) -- TODO: Generate withdrawals
+        ]
+    MaryEra ->
+      Gen.choice
+        [ pure TxWithdrawalsNone
+        , pure (TxWithdrawals WithdrawalsInMaryEra mempty) -- TODO: Generate withdrawals
+        ]
+
+genTxCertificates :: CardanoEra era -> Gen (TxCertificates era)
+genTxCertificates era =
+  case era of
+    ByronEra -> pure TxCertificatesNone
+    ShelleyEra ->
+      Gen.choice
+        [ pure TxCertificatesNone
+        , pure (TxCertificates CertificatesInShelleyEra mempty) -- TODO: Generate certificates
+        ]
+    AllegraEra ->
+      Gen.choice
+        [ pure TxCertificatesNone
+        , pure (TxCertificates CertificatesInAllegraEra mempty) -- TODO: Generate certificates
+        ]
+    MaryEra ->
+      Gen.choice
+        [ pure TxCertificatesNone
+        , pure (TxCertificates CertificatesInMaryEra mempty) -- TODO: Generate certificates
+        ]
+
+genTxUpdateProposal :: CardanoEra era -> Gen (TxUpdateProposal era)
+genTxUpdateProposal era =
+  case era of
+    ByronEra -> pure TxUpdateProposalNone
+    ShelleyEra ->
+      Gen.choice
+        [ pure TxUpdateProposalNone
+        , pure (TxUpdateProposal UpdateProposalInShelleyEra emptyUpdateProposal) -- TODO: Generate proposals
+        ]
+    AllegraEra ->
+      Gen.choice
+        [ pure TxUpdateProposalNone
+        , pure (TxUpdateProposal UpdateProposalInAllegraEra emptyUpdateProposal) -- TODO: Generate proposals
+        ]
+    MaryEra ->
+      Gen.choice
+        [ pure TxUpdateProposalNone
+        , pure (TxUpdateProposal UpdateProposalInMaryEra emptyUpdateProposal) -- TODO: Generate proposals
+        ]
+  where
+    emptyUpdateProposal :: UpdateProposal
+    emptyUpdateProposal = UpdateProposal Map.empty (EpochNo 0)
+
+genTxMintValue :: CardanoEra era -> Gen (TxMintValue era)
+genTxMintValue era =
+  case era of
+    ByronEra -> pure TxMintNone
+    ShelleyEra -> pure TxMintNone
+    AllegraEra -> pure TxMintNone
+    MaryEra ->
+      Gen.choice
+        [ pure TxMintNone
+        , TxMintValue MultiAssetInMaryEra <$> genValue
+        ]
+
+genTxBodyContent :: CardanoEra era -> Gen (TxBodyContent era)
+genTxBodyContent era = do
+  trxIns <- Gen.list (Range.constant 1 10) genTxIn
+  trxOuts <- Gen.list (Range.constant 1 10) (genTxOut era)
+  fee <- genTxFee era
+  validityRange <- genTxValidityRange era
+  txMd <- genTxMetadataInEra era
+  auxScripts <- genTxAuxScripts era
+  withdrawals <- genTxWithdrawals era
+  certs <- genTxCertificates era
+  updateProposal <- genTxUpdateProposal era
+  mintValue <- genTxMintValue era
+
+  pure $ TxBodyContent
+    { txIns = trxIns
+    , txOuts = trxOuts
+    , txFee = fee
+    , txValidityRange = validityRange
+    , txMetadata = txMd
+    , txAuxScripts = auxScripts
+    , txWithdrawals = withdrawals
+    , txCertificates = certs
+    , txUpdateProposal = updateProposal
+    , txMintValue = mintValue
+    }
+
+genTxFee :: CardanoEra era -> Gen (TxFee era)
+genTxFee era =
+  case era of
+    ByronEra -> pure TxFeeImplicit
+    ShelleyEra -> TxFeeExplicit TxFeesExplicitInShelleyEra <$> genLovelace
+    AllegraEra -> TxFeeExplicit TxFeesExplicitInAllegraEra <$> genLovelace
+    MaryEra -> TxFeeExplicit TxFeesExplicitInMaryEra <$> genLovelace
 
 genVerificationKey :: Key keyrole => AsType keyrole -> Gen (VerificationKey keyrole)
 genVerificationKey roletoken = getVerificationKey <$> genSigningKey roletoken
@@ -355,11 +583,6 @@ genShelleyWitnessSigningKey =
              , WitnessGenesisDelegateKey <$>  genSigningKey AsGenesisDelegateKey
              , WitnessGenesisUTxOKey <$>  genSigningKey AsGenesisUTxOKey
              ]
-{-
--- TODO: makeScriptWitness = undefined
-genShelleyScriptWitness :: Gen (Witness Shelley)
-genShelleyScriptWitness = makeScriptWitness
--}
 
 genSeed :: Int -> Gen Crypto.Seed
 genSeed n = Crypto.mkSeedFromBytes <$> Gen.bytes (Range.singleton n)