to sep

IntersectMBO · Apr 6, 2021 · 429b1ee · 429b1ee
1 parent 5bcfc61
commit 429b1ee
Show file tree

Hide file tree

Showing 6 changed files with 365 additions and 129 deletions.
diff --git a/cardano-api/test/Test/Cardano/Api/Typed/Gen.hs b/cardano-api/test/Test/Cardano/Api/Typed/Gen.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -81,8 +80,7 @@ genLovelace = Lovelace <$> Gen.integral (Range.linear 0 5000)
 genScript :: ScriptLanguage lang -> Gen (Script lang)
 genScript (SimpleScriptLanguage lang) =
     SimpleScript lang <$> genSimpleScript lang
-
-genScript (PlutusScriptLanguage lang) = case lang of {}
+genScript (PlutusScriptLanguage PlutusScriptV1) = Gen.discard
 
 genSimpleScript :: SimpleScriptVersion lang -> Gen (SimpleScript lang)
 genSimpleScript lang =
@@ -316,11 +314,13 @@ genByronTxOut :: Gen (TxOut ByronEra)
 genByronTxOut =
   TxOut <$> (byronAddressInEra <$> genAddressByron)
         <*> (TxOutAdaOnly AdaOnlyInByronEra <$> genLovelace)
+        <*> return DataHashNone
 
 genShelleyTxOut :: Gen (TxOut ShelleyEra)
 genShelleyTxOut =
   TxOut <$> (shelleyAddressInEra <$> genAddressShelley)
         <*> (TxOutAdaOnly AdaOnlyInShelleyEra <$> genLovelace)
+        <*> return DataHashNone
 
 genShelleyHash :: Gen (Crypto.Hash Crypto.Blake2b_256 Ledger.EraIndependentTxBody)
 genShelleyHash = return . Crypto.castHash $ Crypto.hashWith CBOR.serialize' ()
@@ -337,7 +337,7 @@ genTxBodyByron = do
     Right txBody -> pure txBody
 
 genTxIn :: Gen TxIn
-genTxIn = TxIn <$> genTxId <*> genTxIndex
+genTxIn = TxIn <$> genTxId <*> genTxIndex <*> return NotPlutusInput
 
 genTxId :: Gen TxId
 genTxId = TxId <$> genShelleyHash
@@ -352,6 +352,7 @@ genTxOutValue era =
     ShelleyEra -> TxOutAdaOnly AdaOnlyInShelleyEra <$> genLovelace
     AllegraEra -> TxOutAdaOnly AdaOnlyInAllegraEra <$> genLovelace
     MaryEra -> TxOutValue MultiAssetInMaryEra <$> genValueForTxOut
+    AlonzoEra -> TxOutValue MultiAssetInAlonzoEra <$> genValueForTxOut
 
 genTxOut :: CardanoEra era -> Gen (TxOut era)
 genTxOut era =
@@ -362,10 +363,17 @@ genTxOut era =
       TxOut
         <$> (shelleyAddressInEra <$> genAddressShelley)
         <*> (TxOutAdaOnly AdaOnlyInAllegraEra <$> genLovelace)
+        <*> return DataHashNone
     MaryEra ->
       TxOut
         <$> (shelleyAddressInEra <$> genAddressShelley)
         <*> genTxOutValue era
+        <*> return DataHashNone
+    AlonzoEra ->
+      TxOut
+        <$> (shelleyAddressInEra <$> genAddressShelley)
+        <*> genTxOutValue era
+        <*> return DataHashNone --TODO: Generate a data hash
 
 genTtl :: Gen SlotNo
 genTtl = genSlotNo
@@ -378,6 +386,7 @@ genTxValidityLowerBound era =
     ShelleyEra -> pure TxValidityNoLowerBound
     AllegraEra -> TxValidityLowerBound ValidityLowerBoundInAllegraEra <$> genTtl
     MaryEra -> TxValidityLowerBound ValidityLowerBoundInMaryEra <$> genTtl
+    AlonzoEra -> TxValidityLowerBound ValidityLowerBoundInAlonzoEra <$> genTtl
 
 -- TODO: Accept a range for generating ttl.
 genTxValidityUpperBound :: CardanoEra era -> Gen (TxValidityUpperBound era)
@@ -387,6 +396,7 @@ genTxValidityUpperBound era =
     ShelleyEra -> TxValidityUpperBound ValidityUpperBoundInShelleyEra <$> genTtl
     AllegraEra -> TxValidityUpperBound ValidityUpperBoundInAllegraEra <$> genTtl
     MaryEra -> TxValidityUpperBound ValidityUpperBoundInMaryEra <$> genTtl
+    AlonzoEra -> TxValidityUpperBound ValidityUpperBoundInAlonzoEra <$> genTtl
 
 genTxValidityRange
   :: CardanoEra era
@@ -415,6 +425,11 @@ genTxMetadataInEra era =
         [ pure TxMetadataNone
         , TxMetadataInEra TxMetadataInMaryEra <$> genTxMetadata
         ]
+    AlonzoEra ->
+      Gen.choice
+        [ pure TxMetadataNone
+        , TxMetadataInEra TxMetadataInAlonzoEra <$> genTxMetadata
+        ]
 
 genTxAuxScripts :: CardanoEra era -> Gen (TxAuxScripts era)
 genTxAuxScripts era =
@@ -427,6 +442,9 @@ genTxAuxScripts era =
     MaryEra    -> TxAuxScripts AuxScriptsInMaryEra
                            <$> Gen.list (Range.linear 0 3)
                                         (genScriptInEra MaryEra)
+    AlonzoEra  -> TxAuxScripts AuxScriptsInAlonzoEra
+                           <$> Gen.list (Range.linear 0 3)
+                                        (genScriptInEra AlonzoEra)
 
 genTxWithdrawals :: CardanoEra era -> Gen (TxWithdrawals era)
 genTxWithdrawals era =
@@ -447,6 +465,11 @@ genTxWithdrawals era =
         [ pure TxWithdrawalsNone
         , pure (TxWithdrawals WithdrawalsInMaryEra mempty) -- TODO: Generate withdrawals
         ]
+    AlonzoEra ->
+      Gen.choice
+        [ pure TxWithdrawalsNone
+        , pure (TxWithdrawals WithdrawalsInAlonzoEra mempty) -- TODO: Generate withdrawals
+        ]
 
 genTxCertificates :: CardanoEra era -> Gen (TxCertificates era)
 genTxCertificates era =
@@ -467,6 +490,11 @@ genTxCertificates era =
         [ pure TxCertificatesNone
         , pure (TxCertificates CertificatesInMaryEra mempty) -- TODO: Generate certificates
         ]
+    AlonzoEra ->
+      Gen.choice
+        [ pure TxCertificatesNone
+        , pure (TxCertificates CertificatesInAlonzoEra  mempty) -- TODO: Generate certificates
+        ]
 
 genTxUpdateProposal :: CardanoEra era -> Gen (TxUpdateProposal era)
 genTxUpdateProposal era =
@@ -487,6 +515,11 @@ genTxUpdateProposal era =
         [ pure TxUpdateProposalNone
         , pure (TxUpdateProposal UpdateProposalInMaryEra emptyUpdateProposal) -- TODO: Generate proposals
         ]
+    AlonzoEra ->
+      Gen.choice
+        [ pure TxUpdateProposalNone
+        , pure (TxUpdateProposal UpdateProposalInAlonzoEra emptyUpdateProposal) -- TODO: Generate proposals
+        ]
   where
     emptyUpdateProposal :: UpdateProposal
     emptyUpdateProposal = UpdateProposal Map.empty (EpochNo 0)
@@ -500,12 +533,26 @@ genTxMintValue era =
     MaryEra ->
       Gen.choice
         [ pure TxMintNone
-        , TxMintValue MultiAssetInMaryEra <$> genValueForMinting
+        , TxMintValue MultiAssetInMaryEra NoPlutusScript <$> genValueForMinting
+        ]
+    AlonzoEra ->
+      Gen.choice
+        [ pure TxMintNone
+        , TxMintValue MultiAssetInAlonzoEra (panic "TODO") <$> genValueForMinting
         ]
 
+genTxExecutionUnits :: CardanoEra era -> Gen (TxExecutionUnits era)
+genTxExecutionUnits era =
+  case executionUnitsSupportedInEra era of
+    Nothing -> return TxExecutionUnitsNone
+    Just supported ->
+      TxExecutionUnits supported
+        <$> Gen.word64 (Range.constant 0 10)
+        <*> Gen.word64 (Range.constant 0 10)
+
 genTxBodyContent :: CardanoEra era -> Gen (TxBodyContent era)
 genTxBodyContent era = do
-  trxIns <- Gen.list (Range.constant 1 10) genTxIn
+  _trxIns <- Gen.list (Range.constant 1 10) genTxIn
   trxOuts <- Gen.list (Range.constant 1 10) (genTxOut era)
   fee <- genTxFee era
   validityRange <- genTxValidityRange era
@@ -515,9 +562,10 @@ genTxBodyContent era = do
   certs <- genTxCertificates era
   updateProposal <- genTxUpdateProposal era
   mintValue <- genTxMintValue era
+  txExecUnits <- genTxExecutionUnits era
 
   pure $ TxBodyContent
-    { txIns = trxIns
+    { txIns = panic "TODO" --trxIns
     , txOuts = trxOuts
     , txFee = fee
     , txValidityRange = validityRange
@@ -527,6 +575,8 @@ genTxBodyContent era = do
     , txCertificates = certs
     , txUpdateProposal = updateProposal
     , txMintValue = mintValue
+    , txExecutionUnits = txExecUnits
+    , txWitnessPPData = panic "TODO"
     }
 
 genTxFee :: CardanoEra era -> Gen (TxFee era)
@@ -536,6 +586,7 @@ genTxFee era =
     ShelleyEra -> TxFeeExplicit TxFeesExplicitInShelleyEra <$> genLovelace
     AllegraEra -> TxFeeExplicit TxFeesExplicitInAllegraEra <$> genLovelace
     MaryEra -> TxFeeExplicit TxFeesExplicitInMaryEra <$> genLovelace
+    AlonzoEra -> TxFeeExplicit TxFeesExplicitInAlonzoEra <$> genLovelace
 
 genTxBody :: CardanoEra era -> Gen (TxBody era)
 genTxBody era =
@@ -552,6 +603,11 @@ genTxBody era =
       case res of
         Left err -> fail (show err) -- TODO: Render function for TxBodyError
         Right txBody -> pure txBody
+    AlonzoEra -> do
+      res <- makeTransactionBody <$> genTxBodyContent AlonzoEra
+      case res of
+        Left err -> fail (show err) -- TODO: Render function for TxBodyError
+        Right txBody -> pure txBody
 
 genTx :: forall era. CardanoEra era -> Gen (Tx era)
 genTx era =
@@ -566,6 +622,7 @@ genTx era =
         ShelleyEra -> genShelleyBasedWitnessList
         AllegraEra -> genShelleyBasedWitnessList
         MaryEra -> genShelleyBasedWitnessList
+        AlonzoEra -> genShelleyBasedWitnessList
 
     genShelleyBasedWitnessList :: IsShelleyBasedEra era => Gen [Witness era]
     genShelleyBasedWitnessList = do
@@ -644,8 +701,8 @@ genMaybePraosNonce :: Gen (Maybe PraosNonce)
 genMaybePraosNonce =
   Gen.maybe (makePraosNonce <$> Gen.bytes (Range.linear 0 32))
 
-genProtocolParameters :: Gen ProtocolParameters
-genProtocolParameters =
+genProtocolParameters :: ShelleyBasedEra era -> Gen (ProtocolParameters era)
+genProtocolParameters _sbe =
   ProtocolParameters
     <$> ((,) <$> genNat <*> genNat)
     <*> genRational
@@ -655,7 +712,7 @@ genProtocolParameters =
     <*> genNat
     <*> genNat
     <*> genNat
-    <*> genLovelace
+    <*> Gen.maybe genLovelace
     <*> genLovelace
     <*> genLovelace
     <*> genLovelace
@@ -664,4 +721,9 @@ genProtocolParameters =
     <*> genRational
     <*> genRational
     <*> genRational
+    <*> return Nothing
+    <*> return Nothing
+    <*> return Nothing
+    <*> return Nothing
+    <*> return Nothing
 
diff --git a/cardano-api/test/Test/Cardano/Api/Typed/JSON.hs b/cardano-api/test/Test/Cardano/Api/Typed/JSON.hs
@@ -28,7 +28,7 @@ prop_roundtrip_praos_nonce_JSON = H.property $ do
 
 prop_roundtrip_protocol_parameters_JSON :: Property
 prop_roundtrip_protocol_parameters_JSON = H.property $ do
-  pp <- forAll genProtocolParameters
+  pp <- forAll $ genProtocolParameters ShelleyBasedEraMary -- TODO: Generate all eras
   tripping pp encode eitherDecode
 
 

diff --git a/cardano-cli/src/Cardano/CLI/Mary/ValueParser.hs b/cardano-cli/src/Cardano/CLI/Mary/ValueParser.hs
@@ -1,5 +1,6 @@
 module Cardano.CLI.Mary.ValueParser
   ( parseValue
+  , policyId
   ) where
 
 import           Prelude