From 405058eec6e39db4e9b8581040d83ed28ab92495 Mon Sep 17 00:00:00 2001 From: Vladimir Kalnitsky Date: Thu, 7 Mar 2024 23:16:55 +0400 Subject: [PATCH] Fix TxConstraints --- packages.dhall | 2 +- src/Contract/Address.purs | 2 +- src/Contract/AssocMap.purs | 2 +- src/Internal/Cardano/Types/Transaction.purs | 914 ------------------ .../Types/TransactionUnspentOutput.purs | 5 - src/Internal/ProcessConstraints/Error.purs | 20 +- src/Internal/ProcessConstraints/State.purs | 44 +- .../ProcessConstraints/UnbalancedTx.purs | 7 +- src/Internal/Types/MintingPolicy.purs | 45 + src/Internal/Types/MintingPolicyHash.purs | 37 + .../Types/NativeScriptStakeValidator.purs | 21 + src/Internal/Types/PaymentPubKey.purs | 4 +- .../Types/PlutusScriptStakeValidator.purs | 31 + src/Internal/Types/ProtocolParameters.purs | 401 ++++---- src/Internal/Types/Rational.purs | 15 +- src/Internal/Types/RawBytes.purs | 4 +- src/Internal/Types/RedeemerTag.purs | 27 +- src/Internal/Types/ScriptLookups.purs | 44 +- src/Internal/Types/Scripts.purs | 177 ---- src/Internal/Types/StakeValidatorHash.purs | 33 + src/Internal/Types/SystemStart.purs | 1 - src/Internal/Types/TxConstraints.purs | 196 +--- src/Internal/Types/UsedTxOuts.purs | 4 +- src/Internal/Types/Validator.purs | 29 + src/Internal/Types/ValidatorHash.purs | 31 + src/Internal/Wallet.purs | 5 +- src/Plutus/PubKeyHash.purs | 41 - 27 files changed, 552 insertions(+), 1590 deletions(-) delete mode 100644 src/Internal/Cardano/Types/Transaction.purs delete mode 100644 src/Internal/Cardano/Types/TransactionUnspentOutput.purs create mode 100644 src/Internal/Types/MintingPolicy.purs create mode 100644 src/Internal/Types/MintingPolicyHash.purs create mode 100644 src/Internal/Types/NativeScriptStakeValidator.purs create mode 100644 src/Internal/Types/PlutusScriptStakeValidator.purs delete mode 100644 src/Internal/Types/Scripts.purs create mode 100644 src/Internal/Types/StakeValidatorHash.purs create mode 100644 src/Internal/Types/Validator.purs create mode 100644 src/Internal/Types/ValidatorHash.purs delete mode 100644 src/Plutus/PubKeyHash.purs diff --git a/packages.dhall b/packages.dhall index 0343af23df..460df870d6 100644 --- a/packages.dhall +++ b/packages.dhall @@ -361,7 +361,7 @@ let additions = , "unsafe-coerce" ] , repo = "https://github.com/mlabs-haskell/purescript-cardano-types" - , version = "288cd06dc89d477b59e158b30803de8f6e535092" + , version = "ce71744f6a6b1f855c325d3abcc8977d99700c2e" } , cardano-message-signing = { dependencies = diff --git a/src/Contract/Address.purs b/src/Contract/Address.purs index 9fb419bb6c..04d3e3710c 100644 --- a/src/Contract/Address.purs +++ b/src/Contract/Address.purs @@ -5,7 +5,7 @@ module Contract.Address import Prelude -import Cardano.Types (Address, NetworkId, Bech32String) +import Cardano.Types (Address, Bech32String, NetworkId) import Cardano.Types.Address as Address import Contract.Monad (Contract, liftContractM) import Control.Monad.Error.Class (throwError) diff --git a/src/Contract/AssocMap.purs b/src/Contract/AssocMap.purs index 419361f046..5bd70dc9e9 100644 --- a/src/Contract/AssocMap.purs +++ b/src/Contract/AssocMap.purs @@ -1,7 +1,7 @@ -- | A module for a Plutus-style `AssocMap` module Contract.AssocMap (module AssocMap) where -import Ctl.Internal.Plutus.Types.AssocMap +import Cardano.Plutus.Types.Map ( Map(Map) , delete , elems diff --git a/src/Internal/Cardano/Types/Transaction.purs b/src/Internal/Cardano/Types/Transaction.purs deleted file mode 100644 index f8ec7535c1..0000000000 --- a/src/Internal/Cardano/Types/Transaction.purs +++ /dev/null @@ -1,914 +0,0 @@ -module Ctl.Internal.Cardano.Types.Transaction - ( AuxiliaryData(AuxiliaryData) - , AuxiliaryDataHash(AuxiliaryDataHash) - , BootstrapWitness - , Certificate - ( StakeRegistration - , StakeDeregistration - , StakeDelegation - , PoolRegistration - , PoolRetirement - , GenesisKeyDelegation - , MoveInstantaneousRewardsCert - ) - , CostModel(CostModel) - , Costmdls(Costmdls) - , mkEd25519Signature - , Epoch(Epoch) - , ExUnitPrices - , ExUnits - , GenesisDelegateHash(GenesisDelegateHash) - , GenesisHash(GenesisHash) - , Ipv4(Ipv4) - , Ipv6(Ipv6) - , MIRToStakeCredentials(MIRToStakeCredentials) - , Mint(Mint) - , MoveInstantaneousReward(ToOtherPot, ToStakeCreds) - , Nonce(IdentityNonce, HashNonce) - , PoolMetadata(PoolMetadata) - , PoolMetadataHash(PoolMetadataHash) - , PoolPubKeyHash(PoolPubKeyHash) - , mkPoolPubKeyHash - , poolPubKeyHashToBech32 - , ProposedProtocolParameterUpdates(ProposedProtocolParameterUpdates) - , ProtocolParamUpdate - , ProtocolVersion - , Redeemer(Redeemer) - , Relay(SingleHostAddr, SingleHostName, MultiHostName) - , RequiredSigner(RequiredSigner) - , ScriptDataHash(ScriptDataHash) - , SubCoin - , Transaction(Transaction) - , PoolRegistrationParams - , TransactionWitnessSet(TransactionWitnessSet) - , TxBody(TxBody) - , URL(URL) - , UnitInterval - , Update - , Vkeywitness(Vkeywitness) - , _auxiliaryData - , _auxiliaryDataHash - , _body - , _bootstraps - , _certs - , _collateral - , _collateralReturn - , _fee - , _inputs - , _isValid - , _mint - , _nativeScripts - , _networkId - , _outputs - , _plutusData - , _plutusScripts - , _redeemers - , _referenceInputs - , _requiredSigners - , _scriptDataHash - , _totalCollateral - , _ttl - , _update - , _validityStartInterval - , _vkeys - , _withdrawals - , _witnessSet - ) where - -import Prelude - -import Aeson - ( class DecodeAeson - , class EncodeAeson - , JsonDecodeError(TypeMismatch) - , caseAesonString - , decodeAeson - , encodeAeson - , finiteNumber - ) -import Cardano.Plutus.Types.PubKeyHash (PubKeyHash(..)) -import Cardano.Serialization.Lib - ( ed25519Signature_fromBech32 - , ed25519Signature_toBech32 - , privateKey_asBytes - , privateKey_toBech32 - , publicKey_asBytes - , publicKey_fromBytes - , publicKey_toBech32 - , toBytes - ) -import Cardano.Serialization.Lib as Csl -import Cardano.Types.Address as Address -import Cardano.AsCbor (encodeCbor) -import Cardano.Types.BigNum (BigNum) -import Cardano.Types.Coin (Coin) -import Cardano.Types.Ed25519Signature (Ed25519Signature(..)) -import Cardano.Types.Language (Language) -import Cardano.Types.MultiAsset (MultiAsset(MultiAsset)) -import Cardano.Types.NetworkId (NetworkId) -import Cardano.Types.OutputDatum (OutputDatum(..)) -import Cardano.Types.PlutusData (PlutusData, pprintPlutusData) -import Cardano.Types.PlutusScript (PlutusScript(..)) -import Cardano.Types.PublicKey (PublicKey(..)) -import Cardano.Types.Slot (Slot(..)) -import Cardano.Types.StakeCredential (StakeCredential(..)) -import Cardano.Types.TransactionOutput (TransactionOutput(..)) -import Cardano.Types.TransactionOutput as X -import Cardano.Types.Value (Value, pprintValue) -import Cardano.Types.Vkey (Vkey(..)) -import Control.Alternative ((<|>)) -import Control.Apply (lift2) -import Ctl.Internal.Cardano.Types.NativeScript (NativeScript) -import Ctl.Internal.Cardano.Types.ScriptRef (ScriptRef) -import Ctl.Internal.FromData (class FromData, fromData) -import Ctl.Internal.Helpers - ( appendMap - , encodeMap - , encodeTagged' - , eqOrd - , () - , (<<>>) - ) -import Ctl.Internal.Serialization.Hash - ( Ed25519KeyHash - , ed25519KeyHashFromBech32 - , ed25519KeyHashToBech32 - , ed25519KeyHashToBech32Unsafe - ) -import Ctl.Internal.ToData (class ToData, toData) -import Ctl.Internal.Types.Aliases (Bech32String) -import Ctl.Internal.Types.Int as Int -import Ctl.Internal.Types.RedeemerTag (RedeemerTag) -import Ctl.Internal.Types.RewardAddress (RewardAddress) -import Ctl.Internal.Types.Transaction (TransactionInput(TransactionInput)) -import Ctl.Internal.Types.TransactionMetadata (GeneralTransactionMetadata) -import Ctl.Internal.Types.VRFKeyHash (VRFKeyHash) -import Data.Array (union) -import Data.ByteArray (ByteArray, byteArrayToHex) -import Data.Either (Either(Left), note) -import Data.Function (on) -import Data.Generic.Rep (class Generic) -import Data.Lens (lens') -import Data.Lens.Iso.Newtype (_Newtype) -import Data.Lens.Record (prop) -import Data.Lens.Types (Lens') -import Data.Log.Tag (TagSet, tag, tagSetTag) -import Data.Log.Tag as TagSet -import Data.Map (Map) -import Data.Map as Map -import Data.Maybe (Maybe(Just, Nothing), fromJust) -import Data.Monoid (guard) -import Data.Newtype (class Newtype, unwrap, wrap) -import Data.Nullable (toMaybe) -import Data.Set (Set) -import Data.Set (union) as Set -import Data.Show.Generic (genericShow) -import Data.String.Utils (startsWith) -import Data.Tuple (Tuple(Tuple)) -import Data.Tuple.Nested (type (/\), (/\)) -import Data.UInt (UInt) -import Data.UInt as UInt -import JS.BigInt (BigInt) -import Partial.Unsafe (unsafePartial) -import Safe.Coerce (coerce) -import Type.Proxy (Proxy(Proxy)) - --------------------------------------------------------------------------------- --- `Transaction` --------------------------------------------------------------------------------- --- note: these types are derived from the cardano-serialization-lib Sundae fork --- the source of truth for these types should be that library and the --- corresponding Rust types -newtype Transaction = Transaction - { body :: TxBody - , witnessSet :: TransactionWitnessSet - , isValid :: Boolean - , auxiliaryData :: Maybe AuxiliaryData - } - -derive instance Generic Transaction _ -derive instance Eq Transaction -derive instance Newtype Transaction _ -derive newtype instance EncodeAeson Transaction - -instance Show Transaction where - show = genericShow - --- instance Semigroup Transaction where --- append (Transaction tx) (Transaction tx') = --- Transaction --- { body: txCheck tx.body <> txCheck' tx'.body --- , witnessSet: txCheck tx.witnessSet <> txCheck' tx'.witnessSet --- , isValid: tx.isValid && tx'.isValid --- , auxiliaryData: txCheck tx.auxiliaryData <> txCheck' tx'.auxiliaryData --- } --- where --- txCheck :: forall (m :: Type). Monoid m => m -> m --- txCheck = guard tx.isValid - --- txCheck' :: forall (m :: Type). Monoid m => m -> m --- txCheck' = guard tx'.isValid - --- instance Monoid Transaction where --- mempty = Transaction --- { body: mempty --- , witnessSet: mempty --- , isValid: true --- , auxiliaryData: Nothing --- } - --------------------------------------------------------------------------------- --- `Transaction` Lenses --------------------------------------------------------------------------------- -_body :: Lens' Transaction TxBody -_body = lens' \(Transaction rec@{ body }) -> - Tuple body \bod -> Transaction rec { body = bod } - -_witnessSet :: Lens' Transaction TransactionWitnessSet -_witnessSet = lens' \(Transaction rec@{ witnessSet }) -> - Tuple witnessSet \ws -> Transaction rec { witnessSet = ws } - -_isValid :: Lens' Transaction Boolean -_isValid = lens' \(Transaction rec@{ isValid }) -> - Tuple isValid \iv -> Transaction rec { isValid = iv } - -_auxiliaryData :: Lens' Transaction (Maybe AuxiliaryData) -_auxiliaryData = lens' \(Transaction rec@{ auxiliaryData }) -> - Tuple auxiliaryData \ad -> Transaction rec { auxiliaryData = ad } - --------------------------------------------------------------------------------- --- `TxBody` --------------------------------------------------------------------------------- --- According to https://github.com/input-output-hk/cardano-ledger/blob/master/eras/babbage/test-suite/cddl-files/babbage.cddl --- requiredSigners is an Array over `VKey`s essentially. But some comments at --- the bottom say it's Maybe? -newtype TxBody = TxBody - { inputs :: Set TransactionInput - , outputs :: Array TransactionOutput - , fee :: Coin - , ttl :: Maybe Slot - , certs :: Maybe (Array Certificate) - , withdrawals :: Maybe (Map RewardAddress Coin) - , update :: Maybe Update - , auxiliaryDataHash :: Maybe AuxiliaryDataHash - , validityStartInterval :: Maybe Slot - , mint :: Maybe Mint - , scriptDataHash :: Maybe ScriptDataHash - , collateral :: Maybe (Array TransactionInput) - , requiredSigners :: Maybe (Array RequiredSigner) - , networkId :: Maybe NetworkId - , collateralReturn :: Maybe TransactionOutput - , totalCollateral :: Maybe Coin - , referenceInputs :: Set TransactionInput - } - -derive instance Generic TxBody _ -derive instance Newtype TxBody _ -derive newtype instance Eq TxBody - -instance Show TxBody where - show = genericShow - --- instance Semigroup TxBody where --- append (TxBody txB) (TxBody txB') = TxBody --- { inputs: txB.inputs `Set.union` txB'.inputs --- , outputs: txB.outputs `union` txB'.outputs --- , fee: txB.fee <> txB'.fee --- , ttl: lift2 lowerbound txB.ttl txB'.ttl --- , certs: lift2 union txB.certs txB'.certs --- , withdrawals: lift2 appendMap txB.withdrawals txB'.withdrawals --- , update: txB.update txB'.update --- , auxiliaryDataHash: txB.auxiliaryDataHash txB'.auxiliaryDataHash --- , validityStartInterval: --- lift2 lowerbound --- txB.validityStartInterval --- txB'.validityStartInterval --- , mint: txB.mint <> txB'.mint --- , referenceInputs: txB.referenceInputs <> txB'.referenceInputs --- , scriptDataHash: txB.scriptDataHash txB'.scriptDataHash --- , collateral: lift2 union txB.collateral txB'.collateral --- , requiredSigners: lift2 union txB.requiredSigners txB'.requiredSigners --- , networkId: txB.networkId txB'.networkId --- , collateralReturn: txB.collateralReturn <|> txB.collateralReturn --- , totalCollateral: txB.totalCollateral <|> txB.totalCollateral --- } --- where --- lowerbound :: Slot -> Slot -> Slot --- lowerbound (Slot x) (Slot y) = Slot $ min x y - --- instance Monoid TxBody where --- mempty = TxBody --- { inputs: mempty --- , outputs: mempty --- , fee: mempty --- , ttl: Nothing --- , certs: Nothing --- , withdrawals: Nothing --- , update: Nothing --- , auxiliaryDataHash: Nothing --- , validityStartInterval: Nothing --- , mint: Nothing --- , scriptDataHash: Nothing --- , collateral: Nothing --- , requiredSigners: Nothing --- , networkId: Nothing --- , collateralReturn: Nothing --- , totalCollateral: Nothing --- , referenceInputs: mempty --- } - -instance EncodeAeson TxBody where - encodeAeson (TxBody r) = encodeAeson $ r - { withdrawals = encodeMap <$> r.withdrawals } - -newtype ScriptDataHash = ScriptDataHash ByteArray - -derive instance Newtype ScriptDataHash _ -derive instance Generic ScriptDataHash _ -derive newtype instance Eq ScriptDataHash -derive newtype instance EncodeAeson ScriptDataHash - -instance Show ScriptDataHash where - show = genericShow - -newtype Mint = Mint MultiAsset - -derive instance Generic Mint _ -derive instance Newtype Mint _ -derive newtype instance Eq Mint -derive newtype instance EncodeAeson Mint -derive newtype instance DecodeAeson Mint - -instance Show Mint where - show = genericShow - -newtype AuxiliaryDataHash = AuxiliaryDataHash ByteArray - -derive instance Generic AuxiliaryDataHash _ -derive instance Newtype AuxiliaryDataHash _ -derive newtype instance Eq AuxiliaryDataHash -derive newtype instance EncodeAeson AuxiliaryDataHash - -instance Show AuxiliaryDataHash where - show = genericShow - -type Update = - { proposedProtocolParameterUpdates :: ProposedProtocolParameterUpdates - , epoch :: Epoch - } - -newtype ProposedProtocolParameterUpdates = - ProposedProtocolParameterUpdates (Map GenesisHash ProtocolParamUpdate) - -derive instance Newtype ProposedProtocolParameterUpdates _ - -derive newtype instance Eq ProposedProtocolParameterUpdates - -derive instance Generic ProposedProtocolParameterUpdates _ - -instance Show ProposedProtocolParameterUpdates where - show = genericShow - -instance EncodeAeson ProposedProtocolParameterUpdates where - encodeAeson (ProposedProtocolParameterUpdates r) = encodeMap r - -newtype GenesisHash = GenesisHash ByteArray - -derive instance Newtype GenesisHash _ -derive newtype instance Eq GenesisHash -derive newtype instance Ord GenesisHash -derive instance Generic GenesisHash _ -derive newtype instance EncodeAeson GenesisHash - -instance Show GenesisHash where - show = genericShow - -type ProtocolParamUpdate = - { minfeeA :: Maybe Coin - , minfeeB :: Maybe Coin - , maxBlockBodySize :: Maybe UInt - , maxTxSize :: Maybe UInt - , maxBlockHeaderSize :: Maybe UInt - , keyDeposit :: Maybe Coin - , poolDeposit :: Maybe Coin - , maxEpoch :: Maybe Epoch - , nOpt :: Maybe UInt - , poolPledgeInfluence :: Maybe UnitInterval - , expansionRate :: Maybe UnitInterval - , treasuryGrowthRate :: Maybe UnitInterval - , protocolVersion :: Maybe ProtocolVersion - , minPoolCost :: Maybe BigNum - , adaPerUtxoByte :: Maybe BigNum - , costModels :: Maybe Costmdls - , executionCosts :: Maybe ExUnitPrices - , maxTxExUnits :: Maybe ExUnits - , maxBlockExUnits :: Maybe ExUnits - , maxValueSize :: Maybe UInt - , collateralPercentage :: Maybe UInt - , maxCollateralInputs :: Maybe UInt - } - -type ExUnitPrices = - { memPrice :: SubCoin - , stepPrice :: SubCoin - } - -type ExUnits = - { mem :: BigInt - , steps :: BigInt - } - -type SubCoin = UnitInterval - -newtype Costmdls = Costmdls (Map Language CostModel) - -derive instance Newtype Costmdls _ -derive newtype instance Eq Costmdls -derive instance Generic Costmdls _ - -instance Show Costmdls where - show = genericShow - -instance EncodeAeson Costmdls where - encodeAeson = encodeMap <<< unwrap - -newtype CostModel = CostModel (Array Int.Int) - -derive instance Newtype CostModel _ -derive newtype instance Eq CostModel -derive newtype instance EncodeAeson CostModel -derive instance Generic Nonce _ -derive instance Generic CostModel _ - -instance Show CostModel where - show = genericShow - -type ProtocolVersion = - { major :: UInt - , minor :: UInt - } - --- Following CSL Nonce is either None or a 32 byte hash -data Nonce = IdentityNonce | HashNonce ByteArray - -derive instance Eq Nonce - -instance Show Nonce where - show = genericShow - -instance DecodeAeson Nonce where - decodeAeson aeson = (HashNonce <$> decodeAeson aeson) <|> - caseAesonString err - ( case _ of - "neutral" -> pure IdentityNonce - _ -> err - ) - aeson - where - err :: Either JsonDecodeError Nonce - err = Left (TypeMismatch "Nonce") - -instance EncodeAeson Nonce where - encodeAeson IdentityNonce = encodeAeson "neutral" - encodeAeson (HashNonce hash) = encodeAeson hash - -type UnitInterval = - { numerator :: BigNum - , denominator :: BigNum - } - -newtype Epoch = Epoch UInt - -derive instance Newtype Epoch _ -derive instance Generic Epoch _ -derive newtype instance Eq Epoch -derive newtype instance EncodeAeson Epoch - -instance Show Epoch where - show = genericShow - -newtype Ipv4 = Ipv4 ByteArray - -derive instance Eq Ipv4 -derive instance Generic Ipv4 _ -derive instance Newtype Ipv4 _ --- TODO: Use a more legible representation -derive newtype instance EncodeAeson Ipv4 - -instance Show Ipv4 where - show = genericShow - -newtype Ipv6 = Ipv6 ByteArray - -derive instance Eq Ipv6 -derive instance Generic Ipv6 _ -derive instance Newtype Ipv6 _ -derive newtype instance EncodeAeson Ipv6 - -instance Show Ipv6 where - show = genericShow - -data Relay - = SingleHostAddr - { port :: Maybe Int - , ipv4 :: Maybe Ipv4 - , ipv6 :: Maybe Ipv6 - } - | SingleHostName - { port :: Maybe Int - , dnsName :: String - } - | MultiHostName { dnsName :: String } - -derive instance Eq Relay -derive instance Generic Relay _ - -instance Show Relay where - show = genericShow - -instance EncodeAeson Relay where - encodeAeson = case _ of - SingleHostAddr r -> encodeTagged' "SingleHostAddr" r - SingleHostName r -> encodeTagged' "SingleHostName" r - MultiHostName r -> encodeTagged' "MultiHostName" r - -newtype URL = URL String - -derive instance Eq URL -derive instance Generic URL _ -derive instance Newtype URL _ -derive newtype instance EncodeAeson URL - -instance Show URL where - show = genericShow - -newtype PoolMetadataHash = PoolMetadataHash ByteArray - -derive instance Eq PoolMetadataHash -derive instance Generic PoolMetadataHash _ -derive instance Newtype PoolMetadataHash _ -derive newtype instance EncodeAeson PoolMetadataHash - -instance Show PoolMetadataHash where - show = genericShow - -newtype PoolMetadata = PoolMetadata - { url :: URL - , hash :: PoolMetadataHash - } - -derive instance Eq PoolMetadata -derive instance Generic PoolMetadata _ -derive newtype instance EncodeAeson PoolMetadata - -instance Show PoolMetadata where - show = genericShow - -newtype GenesisDelegateHash = GenesisDelegateHash ByteArray - -derive instance Eq GenesisDelegateHash -derive instance Generic GenesisDelegateHash _ -derive newtype instance EncodeAeson GenesisDelegateHash - -instance Show GenesisDelegateHash where - show = genericShow - -newtype MIRToStakeCredentials = MIRToStakeCredentials - (Map StakeCredential Int.Int) - -derive instance Eq MIRToStakeCredentials -derive instance Generic MIRToStakeCredentials _ - -instance Show MIRToStakeCredentials where - show = genericShow - -instance EncodeAeson MIRToStakeCredentials where - encodeAeson (MIRToStakeCredentials r) = encodeMap r - -data MoveInstantaneousReward - = ToOtherPot - { pot :: Number - , amount :: BigNum - } - | ToStakeCreds - { pot :: Number - , amounts :: MIRToStakeCredentials - } - -derive instance Eq MoveInstantaneousReward -derive instance Generic MoveInstantaneousReward _ - -instance Show MoveInstantaneousReward where - show = genericShow - -instance EncodeAeson MoveInstantaneousReward where - encodeAeson = case _ of - ToOtherPot r -> encodeTagged' "ToOtherPot" r - -- We assume the numbers are finite - { pot = unsafePartial $ fromJust $ finiteNumber r.pot } - ToStakeCreds r -> encodeTagged' "ToStakeCreds" r - -- We assume the numbers are finite - { pot = unsafePartial $ fromJust $ finiteNumber r.pot } - -type PoolRegistrationParams = - { operator :: PoolPubKeyHash -- cwitness (cert) - , vrfKeyhash :: VRFKeyHash - -- needed to prove that the pool won the lottery - , pledge :: BigNum - , cost :: BigNum -- >= pparams.minPoolCost - , margin :: UnitInterval -- proportion that goes to the reward account - , rewardAccount :: RewardAddress - , poolOwners :: Array PubKeyHash - -- payment key hashes that contribute to pledge amount - , relays :: Array Relay - , poolMetadata :: Maybe PoolMetadata - } - -newtype PoolPubKeyHash = PoolPubKeyHash PubKeyHash - -derive instance Newtype PoolPubKeyHash _ -derive instance Eq PoolPubKeyHash -derive instance Ord PoolPubKeyHash -derive instance Generic PoolPubKeyHash _ -derive newtype instance ToData PoolPubKeyHash -derive newtype instance FromData PoolPubKeyHash - -instance EncodeAeson PoolPubKeyHash where - encodeAeson (PoolPubKeyHash kh) = - encodeAeson (ed25519KeyHashToBech32 "pool" $ unwrap kh) - -instance DecodeAeson PoolPubKeyHash where - decodeAeson aeson = do - str <- decodeAeson aeson - PoolPubKeyHash <<< PubKeyHash <$> note (TypeMismatch "PoolPubKeyHash") - (ed25519KeyHashFromBech32 str) - -instance Show PoolPubKeyHash where - show (PoolPubKeyHash kh) = - "(PoolPubKeyHash (Ed25519KeyHash (unsafePartial $ fromJust $ \ - \ed25519KeyHashFromBech32 " - <> show (ed25519KeyHashToBech32 "pool" $ unwrap kh) - <> ")))" - -mkPoolPubKeyHash :: Bech32String -> Maybe PoolPubKeyHash -mkPoolPubKeyHash str - | startsWith "pool" str = PoolPubKeyHash <<< PubKeyHash <$> - ed25519KeyHashFromBech32 str - | otherwise = Nothing - -poolPubKeyHashToBech32 :: PoolPubKeyHash -> Bech32String -poolPubKeyHashToBech32 = unsafePartial $ unwrap >>> unwrap >>> - ed25519KeyHashToBech32Unsafe "pool" - -data Certificate - = StakeRegistration StakeCredential - | StakeDeregistration StakeCredential - | StakeDelegation StakeCredential PoolPubKeyHash - | PoolRegistration PoolRegistrationParams - | PoolRetirement - { poolKeyHash :: PoolPubKeyHash - , epoch :: Epoch - } - | GenesisKeyDelegation - { genesisHash :: GenesisHash - , genesisDelegateHash :: GenesisDelegateHash - , vrfKeyhash :: VRFKeyHash - } - | MoveInstantaneousRewardsCert MoveInstantaneousReward - -derive instance Eq Certificate -derive instance Generic Certificate _ - -instance Show Certificate where - show = genericShow - -instance EncodeAeson Certificate where - encodeAeson = case _ of - StakeRegistration r -> encodeTagged' "StakeRegistration" r - StakeDeregistration r -> encodeTagged' "StakeDeregistration" - r - StakeDelegation cred hash -> encodeTagged' "StakeDelegation" - { stakeCredential: cred, ed25519KeyHash: hash } - PoolRegistration r -> encodeTagged' "PoolRegistration" r - PoolRetirement r -> encodeTagged' "PoolRetirement" r - GenesisKeyDelegation r -> encodeTagged' - "GenesisKeyDelegation" - r - MoveInstantaneousRewardsCert r -> encodeTagged' - "MoveInstantaneousReward" - r - --------------------------------------------------------------------------------- --- `TxBody` Lenses --------------------------------------------------------------------------------- - -_inputs :: Lens' TxBody (Set TransactionInput) -_inputs = _Newtype <<< prop (Proxy :: Proxy "inputs") - -_outputs :: Lens' TxBody (Array TransactionOutput) -_outputs = _Newtype <<< prop (Proxy :: Proxy "outputs") - -_fee :: Lens' TxBody (Coin) -_fee = _Newtype <<< prop (Proxy :: Proxy "fee") - -_ttl :: Lens' TxBody (Maybe Slot) -_ttl = _Newtype <<< prop (Proxy :: Proxy "ttl") - -_certs :: Lens' TxBody (Maybe (Array Certificate)) -_certs = _Newtype <<< prop (Proxy :: Proxy "certs") - -_withdrawals :: Lens' TxBody (Maybe (Map RewardAddress Coin)) -_withdrawals = _Newtype <<< prop (Proxy :: Proxy "withdrawals") - -_update :: Lens' TxBody (Maybe Update) -_update = _Newtype <<< prop (Proxy :: Proxy "update") - -_auxiliaryDataHash :: Lens' TxBody (Maybe AuxiliaryDataHash) -_auxiliaryDataHash = _Newtype <<< prop (Proxy :: Proxy "auxiliaryDataHash") - -_validityStartInterval :: Lens' TxBody (Maybe Slot) -_validityStartInterval = - _Newtype <<< prop (Proxy :: Proxy "validityStartInterval") - -_mint :: Lens' TxBody (Maybe Mint) -_mint = _Newtype <<< prop (Proxy :: Proxy "mint") - -_scriptDataHash :: Lens' TxBody (Maybe ScriptDataHash) -_scriptDataHash = _Newtype <<< prop (Proxy :: Proxy "scriptDataHash") - -_collateral :: Lens' TxBody (Maybe (Array TransactionInput)) -_collateral = _Newtype <<< prop (Proxy :: Proxy "collateral") - -_requiredSigners :: Lens' TxBody (Maybe (Array RequiredSigner)) -_requiredSigners = _Newtype <<< prop (Proxy :: Proxy "requiredSigners") - -_networkId :: Lens' TxBody (Maybe NetworkId) -_networkId = _Newtype <<< prop (Proxy :: Proxy "networkId") - -_referenceInputs :: Lens' TxBody (Set TransactionInput) -_referenceInputs = _Newtype <<< prop (Proxy :: Proxy "referenceInputs") - -_collateralReturn :: Lens' TxBody (Maybe TransactionOutput) -_collateralReturn = _Newtype <<< prop (Proxy :: Proxy "collateralReturn") - -_totalCollateral :: Lens' TxBody (Maybe Coin) -_totalCollateral = _Newtype <<< prop (Proxy :: Proxy "totalCollateral") - --------------------------------------------------------------------------------- --- `TransactionWitnessSet` --------------------------------------------------------------------------------- -newtype TransactionWitnessSet = TransactionWitnessSet - { vkeys :: Maybe (Array Vkeywitness) - , nativeScripts :: Maybe (Array NativeScript) - , bootstraps :: Maybe (Array BootstrapWitness) - , plutusScripts :: Maybe (Array PlutusScript) - , plutusData :: Maybe (Array PlutusData) - , redeemers :: Maybe (Array Redeemer) - } - -derive instance Generic TransactionWitnessSet _ -derive instance Newtype TransactionWitnessSet _ -derive newtype instance Eq TransactionWitnessSet -derive newtype instance EncodeAeson TransactionWitnessSet - -instance Show TransactionWitnessSet where - show = genericShow - -instance Semigroup TransactionWitnessSet where - append (TransactionWitnessSet tws) (TransactionWitnessSet tws') = - TransactionWitnessSet - { vkeys: tws.vkeys <<>> tws'.vkeys - , nativeScripts: tws.nativeScripts <<>> tws'.nativeScripts - , bootstraps: tws.bootstraps <<>> tws'.bootstraps - , plutusScripts: tws.plutusScripts <<>> tws'.plutusScripts - , plutusData: tws.plutusData <<>> tws'.plutusData - , redeemers: tws.redeemers <<>> tws'.redeemers - } - -instance Monoid TransactionWitnessSet where - mempty = TransactionWitnessSet - { vkeys: Nothing - , nativeScripts: Nothing - , bootstraps: Nothing - , plutusScripts: Nothing - , plutusData: Nothing - , redeemers: Nothing - } - --------------------------------------------------------------------------------- --- `TransactionWitnessSet` Lenses --------------------------------------------------------------------------------- -_vkeys :: Lens' TransactionWitnessSet (Maybe (Array Vkeywitness)) -_vkeys = lens' \(TransactionWitnessSet rec@{ vkeys }) -> - Tuple vkeys \vk -> TransactionWitnessSet rec { vkeys = vk } - -_nativeScripts :: Lens' TransactionWitnessSet (Maybe (Array NativeScript)) -_nativeScripts = lens' \(TransactionWitnessSet rec@{ nativeScripts }) -> - Tuple nativeScripts \ns -> TransactionWitnessSet rec { nativeScripts = ns } - -_bootstraps :: Lens' TransactionWitnessSet (Maybe (Array BootstrapWitness)) -_bootstraps = lens' \(TransactionWitnessSet rec@{ bootstraps }) -> - Tuple bootstraps \bs -> TransactionWitnessSet rec { bootstraps = bs } - -_plutusScripts :: Lens' TransactionWitnessSet (Maybe (Array PlutusScript)) -_plutusScripts = lens' \(TransactionWitnessSet rec@{ plutusScripts }) -> - Tuple plutusScripts \ps -> TransactionWitnessSet rec { plutusScripts = ps } - -_plutusData :: Lens' TransactionWitnessSet (Maybe (Array PlutusData)) -_plutusData = lens' \(TransactionWitnessSet rec@{ plutusData }) -> - Tuple plutusData \pd -> TransactionWitnessSet rec { plutusData = pd } - -_redeemers :: Lens' TransactionWitnessSet (Maybe (Array Redeemer)) -_redeemers = lens' \(TransactionWitnessSet rec@{ redeemers }) -> - Tuple redeemers \red -> TransactionWitnessSet rec { redeemers = red } - --------------------------------------------------------------------------------- --- Other Datatypes --------------------------------------------------------------------------------- -type BootstrapWitness = - { vkey :: Vkey - , signature :: Ed25519Signature - , chainCode :: ByteArray - , attributes :: ByteArray - } - -newtype RequiredSigner = RequiredSigner Ed25519KeyHash - -derive instance Newtype RequiredSigner _ -derive newtype instance Eq RequiredSigner -derive newtype instance Ord RequiredSigner -derive newtype instance EncodeAeson RequiredSigner -derive instance Generic RequiredSigner _ - -instance Show RequiredSigner where - show = genericShow - -newtype Vkeywitness = Vkeywitness (Vkey /\ Ed25519Signature) - -derive instance Generic Vkeywitness _ -derive newtype instance Eq Vkeywitness -derive newtype instance EncodeAeson Vkeywitness -derive instance Newtype Vkeywitness _ - -instance Show Vkeywitness where - show = genericShow - --- ToData/FromData instances are intentionally not provided: --- it is pointless to store PrivateKeys in plutus script contexts, --- so the instances are commented-out to prevent people from doing --- something dangerous. - --- instance ToData PrivateKey where --- toData (PrivateKey pk) = toData $ privateKey_asBytes pk - --- instance FromData PrivateKey where --- fromData = map wrap <<< toMaybe <<< privateKey_fromNormalBytes <=< fromData - -mkEd25519Signature :: Bech32String -> Maybe Ed25519Signature -mkEd25519Signature = - coerce <<< toMaybe <<< ed25519Signature_fromBech32 - -newtype Redeemer = Redeemer - { tag :: RedeemerTag - , index :: BigInt - , data :: PlutusData - , exUnits :: ExUnits - } - -derive instance Generic Redeemer _ -derive instance Newtype Redeemer _ -derive newtype instance Eq Redeemer -derive newtype instance Ord Redeemer -derive newtype instance EncodeAeson Redeemer - -instance Show Redeemer where - show = genericShow - -newtype AuxiliaryData = AuxiliaryData - { metadata :: Maybe GeneralTransactionMetadata - , nativeScripts :: Maybe (Array NativeScript) - , plutusScripts :: Maybe (Array PlutusScript) - } - -derive instance Generic AuxiliaryData _ -derive instance Newtype AuxiliaryData _ -derive newtype instance Eq AuxiliaryData -derive newtype instance EncodeAeson AuxiliaryData - -instance Show AuxiliaryData where - show = genericShow - -instance Semigroup AuxiliaryData where - append (AuxiliaryData ad) (AuxiliaryData ad') = - AuxiliaryData - { metadata: ad.metadata <> ad'.metadata - , nativeScripts: lift2 union ad.nativeScripts ad'.nativeScripts - , plutusScripts: lift2 union ad.plutusScripts ad'.plutusScripts - } - -instance Monoid AuxiliaryData where - mempty = AuxiliaryData - { metadata: Nothing - , nativeScripts: Nothing - , plutusScripts: Nothing - } diff --git a/src/Internal/Cardano/Types/TransactionUnspentOutput.purs b/src/Internal/Cardano/Types/TransactionUnspentOutput.purs deleted file mode 100644 index f753fe358a..0000000000 --- a/src/Internal/Cardano/Types/TransactionUnspentOutput.purs +++ /dev/null @@ -1,5 +0,0 @@ -module Ctl.Internal.Cardano.Types.TransactionUnspentOutput - ( module X - ) where - -import Cardano.Types.TransactionUnspentOutput as X diff --git a/src/Internal/ProcessConstraints/Error.purs b/src/Internal/ProcessConstraints/Error.purs index 8ecebde233..74875541c0 100644 --- a/src/Internal/ProcessConstraints/Error.purs +++ b/src/Internal/ProcessConstraints/Error.purs @@ -13,11 +13,23 @@ import Cardano.Types.PlutusData (PlutusData) import Cardano.Types.PlutusScript (PlutusScript(PlutusScript)) import Cardano.Types.ScriptHash (ScriptHash) import Cardano.Types.StakePubKeyHash (StakePubKeyHash) -import Cardano.Types.TransactionInput (TransactionInput(..)) -import Cardano.Types.TransactionOutput (TransactionOutput, pprintTransactionOutput) +import Cardano.Types.TransactionInput (TransactionInput(TransactionInput)) +import Cardano.Types.TransactionOutput + ( TransactionOutput + , pprintTransactionOutput + ) import Ctl.Internal.Helpers (bugTrackerLink, pprintTagSet) -import Ctl.Internal.Types.Interval (POSIXTimeRange, PosixTimeToSlotError, explainPosixTimeToSlotError) -import Ctl.Internal.Types.Scripts (MintingPolicyHash, NativeScriptStakeValidator, PlutusScriptStakeValidator, ValidatorHash) +import Ctl.Internal.Types.Interval + ( POSIXTimeRange + , PosixTimeToSlotError + , explainPosixTimeToSlotError + ) +import Ctl.Internal.Types.Scripts + ( MintingPolicyHash + , NativeScriptStakeValidator + , PlutusScriptStakeValidator + , ValidatorHash + ) import Data.ByteArray (byteArrayToHex) import Data.Generic.Rep (class Generic) import Data.Log.Tag (tagSetTag) diff --git a/src/Internal/ProcessConstraints/State.purs b/src/Internal/ProcessConstraints/State.purs index aca0d685d4..3d5c528d76 100644 --- a/src/Internal/ProcessConstraints/State.purs +++ b/src/Internal/ProcessConstraints/State.purs @@ -19,17 +19,12 @@ module Ctl.Internal.ProcessConstraints.State import Prelude hiding (join) -import Cardano.Types.TransactionInput (TransactionInput) +import Cardano.Types (CostModel, Language, Transaction, UtxoMap) +import Cardano.Types.Value (Value) +import Cardano.Types.Value as Value import Control.Monad.State.Trans (StateT) import Ctl.Internal.BalanceTx.RedeemerIndex (UnindexedRedeemer) -import Ctl.Internal.Cardano.Types.Transaction - ( Costmdls - , Transaction - , TransactionOutput - ) -import Ctl.Internal.Cardano.Types.Value (Value, negation, split) import Ctl.Internal.Contract.Monad (Contract) -import Ctl.Internal.Plutus.Types.Transaction (TransactionOutputWithRefScript) as Plutus import Ctl.Internal.Types.Datum (Datum) import Ctl.Internal.Types.ScriptLookups (ScriptLookups) import Data.Generic.Rep (class Generic) @@ -37,8 +32,8 @@ import Data.Lattice (join) import Data.Lens.Record (prop) import Data.Lens.Types (Lens') import Data.Map (Map) +import Data.Maybe (Maybe) import Data.Show.Generic (genericShow) -import Data.Tuple.Nested ((/\)) import Type.Proxy (Proxy(Proxy)) -- A `StateT` ontop of `QueryM` ~ ReaderT QueryConfig Aff`. @@ -54,7 +49,7 @@ type ConstraintsM (a :: Type) = type ConstraintProcessingState = { transaction :: Transaction -- ^ The unbalanced transaction that we're building - , usedUtxos :: Map TransactionInput TransactionOutput + , usedUtxos :: UtxoMap -- ^ All UTxOs that are used in the Tx , valueSpentBalancesInputs :: ValueSpentBalances -- ^ Balance of the values given and required for the transaction's inputs @@ -69,9 +64,8 @@ type ConstraintProcessingState = -- ^ ScriptLookups for resolving constraints. Should be treated as an immutable -- value despite living inside the processing state -- TODO: remove: https://github.com/Plutonomicon/cardano-transaction-lib/issues/843 - , refScriptsUtxoMap :: - Map TransactionInput Plutus.TransactionOutputWithRefScript - , costModels :: Costmdls + , refScriptsUtxoMap :: UtxoMap + , costModels :: Map Language CostModel } _cpsTransaction @@ -79,8 +73,7 @@ _cpsTransaction _cpsTransaction = prop (Proxy :: Proxy "transaction") _cpsUsedUtxos - :: Lens' ConstraintProcessingState - (Map TransactionInput TransactionOutput) + :: Lens' ConstraintProcessingState UtxoMap _cpsUsedUtxos = prop (Proxy :: Proxy "usedUtxos") _valueSpentBalancesInputs @@ -96,7 +89,7 @@ _datums _datums = prop (Proxy :: Proxy "datums") _costModels - :: Lens' ConstraintProcessingState Costmdls + :: Lens' ConstraintProcessingState (Map Language CostModel) _costModels = prop (Proxy :: Proxy "costModels") _redeemers @@ -108,8 +101,7 @@ _lookups _lookups = prop (Proxy :: Proxy "lookups") _refScriptsUtxoMap - :: Lens' ConstraintProcessingState - (Map TransactionInput Plutus.TransactionOutputWithRefScript) + :: Lens' ConstraintProcessingState UtxoMap _refScriptsUtxoMap = prop (Proxy :: Proxy "refScriptsUtxoMap") -- | The balances we track for computing the missing 'Value' (if any) @@ -133,21 +125,17 @@ instance Semigroup ValueSpentBalances where , provided: l.provided `join` r.provided } -missingValueSpent :: ValueSpentBalances -> Value +missingValueSpent :: ValueSpentBalances -> Maybe Value missingValueSpent (ValueSpentBalances { required, provided }) = - let - difference = required <> negation provided - _ /\ missing = split difference - in - missing + Value.minus required provided -totalMissingValue :: ConstraintProcessingState -> Value +totalMissingValue :: ConstraintProcessingState -> Maybe Value totalMissingValue { valueSpentBalancesInputs, valueSpentBalancesOutputs } = - missingValueSpent valueSpentBalancesInputs `join` + join <$> missingValueSpent valueSpentBalancesInputs <*> missingValueSpent valueSpentBalancesOutputs provideValue :: Value -> ValueSpentBalances -provideValue provided = ValueSpentBalances { provided, required: mempty } +provideValue provided = ValueSpentBalances { provided, required: Value.zero } requireValue :: Value -> ValueSpentBalances -requireValue required = ValueSpentBalances { required, provided: mempty } +requireValue required = ValueSpentBalances { required, provided: Value.zero } diff --git a/src/Internal/ProcessConstraints/UnbalancedTx.purs b/src/Internal/ProcessConstraints/UnbalancedTx.purs index 81b92a3c28..deee552482 100644 --- a/src/Internal/ProcessConstraints/UnbalancedTx.purs +++ b/src/Internal/ProcessConstraints/UnbalancedTx.purs @@ -4,11 +4,11 @@ module Ctl.Internal.ProcessConstraints.UnbalancedTx import Prelude hiding (join) +import Cardano.Types.PlutusData (PlutusData) +import Cardano.Types.Transaction (Transaction) import Cardano.Types.TransactionInput (TransactionInput) import Cardano.Types.TransactionOutput (TransactionOutput) import Ctl.Internal.BalanceTx.RedeemerIndex (UnindexedRedeemer) -import Ctl.Internal.Cardano.Types.Transaction (Transaction) -import Ctl.Internal.Types.Datum (Datum) import Data.Generic.Rep (class Generic) import Data.Map (Map) import Data.Newtype (class Newtype) @@ -19,7 +19,8 @@ import Data.Show.Generic (genericShow) newtype UnbalancedTx = UnbalancedTx { transaction :: Transaction -- the unbalanced tx created , usedUtxos :: Map TransactionInput TransactionOutput - , datums :: Array Datum -- the array of ordered datums that require attaching + , datums :: + Array PlutusData -- the array of ordered datums that require attaching , redeemers :: Array UnindexedRedeemer } diff --git a/src/Internal/Types/MintingPolicy.purs b/src/Internal/Types/MintingPolicy.purs new file mode 100644 index 0000000000..beedd0765d --- /dev/null +++ b/src/Internal/Types/MintingPolicy.purs @@ -0,0 +1,45 @@ +module Ctl.Internal.Types.MintingPolicy + ( MintingPolicy(PlutusMintingPolicy, NativeMintingPolicy) + , hash + ) where + +import Prelude + +import Aeson (class DecodeAeson, class EncodeAeson, encodeAeson) +import Cardano.Plutus.Types.MintingPolicyHash (MintingPolicyHash) +import Cardano.Types.NativeScript (NativeScript) +import Cardano.Types.NativeScript as NativeScript +import Cardano.Types.PlutusScript (PlutusScript) +import Cardano.Types.PlutusScript as PlutusScript +import Control.Alt ((<|>)) +import Ctl.Internal.Helpers (decodeTaggedNewtype) +import Data.Generic.Rep (class Generic) +import Data.Newtype (wrap) +import Data.Show.Generic (genericShow) + +-- | `MintingPolicy` is a sum type of `PlutusScript` and `NativeScript` which are used as +-- | validators for minting constraints. +data MintingPolicy + = PlutusMintingPolicy PlutusScript + | NativeMintingPolicy NativeScript + +derive instance Generic MintingPolicy _ +derive instance Eq MintingPolicy + +instance DecodeAeson MintingPolicy where + decodeAeson aes = + decodeTaggedNewtype "getPlutusMintingPolicy" PlutusMintingPolicy aes <|> + decodeTaggedNewtype "getNativeMintingPolicy" NativeMintingPolicy aes + +instance EncodeAeson MintingPolicy where + encodeAeson (NativeMintingPolicy nscript) = + encodeAeson { "getNativeMintingPolicy": nscript } + encodeAeson (PlutusMintingPolicy script) = + encodeAeson { "getPlutusMintingPolicy": script } + +instance Show MintingPolicy where + show = genericShow + +hash :: MintingPolicy -> MintingPolicyHash +hash (PlutusMintingPolicy ps) = wrap $ PlutusScript.hash ps +hash (NativeMintingPolicy ns) = wrap $ NativeScript.hash ns diff --git a/src/Internal/Types/MintingPolicyHash.purs b/src/Internal/Types/MintingPolicyHash.purs new file mode 100644 index 0000000000..73d438b27f --- /dev/null +++ b/src/Internal/Types/MintingPolicyHash.purs @@ -0,0 +1,37 @@ +module Ctl.Internal.Types.MintingPolicyHash + ( MintingPolicyHash(MintingPolicyHash) + ) where + +import Prelude + +import Aeson (class DecodeAeson, class EncodeAeson, encodeAeson) +import Cardano.FromData (class FromData) +import Cardano.FromMetadata (class FromMetadata) +import Cardano.ToData (class ToData) +import Cardano.ToMetadata (class ToMetadata) +import Cardano.Types.ScriptHash (ScriptHash) +import Ctl.Internal.Helpers (decodeTaggedNewtype) +import Data.Generic.Rep (class Generic) +import Data.Newtype (class Newtype) +import Data.Show.Generic (genericShow) + +newtype MintingPolicyHash = MintingPolicyHash ScriptHash + +derive instance Generic MintingPolicyHash _ +derive instance Newtype MintingPolicyHash _ +derive newtype instance Eq MintingPolicyHash +derive newtype instance Ord MintingPolicyHash +derive newtype instance FromData MintingPolicyHash +derive newtype instance ToData MintingPolicyHash +derive newtype instance FromMetadata MintingPolicyHash +derive newtype instance ToMetadata MintingPolicyHash + +instance DecodeAeson MintingPolicyHash where + decodeAeson = decodeTaggedNewtype "getMintingPolicyHash" MintingPolicyHash + +instance EncodeAeson MintingPolicyHash where + encodeAeson (MintingPolicyHash hash) = + encodeAeson { "getMintingPolicyHash": hash } + +instance Show MintingPolicyHash where + show = genericShow diff --git a/src/Internal/Types/NativeScriptStakeValidator.purs b/src/Internal/Types/NativeScriptStakeValidator.purs new file mode 100644 index 0000000000..de84e0d280 --- /dev/null +++ b/src/Internal/Types/NativeScriptStakeValidator.purs @@ -0,0 +1,21 @@ +module Ctl.Internal.Types.NativeScriptStakeValidator + ( NativeScriptStakeValidator(NativeScriptStakeValidator) + ) where + +import Prelude + +import Cardano.Types.NativeScript (NativeScript) +import Data.Generic.Rep (class Generic) +import Data.Newtype (class Newtype) +import Data.Show.Generic (genericShow) + +-- | `NativeScriptStakeValidator`s are used as validators for withdrawals and +-- | stake address certificates. +newtype NativeScriptStakeValidator = NativeScriptStakeValidator NativeScript + +derive instance Newtype NativeScriptStakeValidator _ +derive instance Generic NativeScriptStakeValidator _ +derive instance Eq NativeScriptStakeValidator + +instance Show NativeScriptStakeValidator where + show = genericShow diff --git a/src/Internal/Types/PaymentPubKey.purs b/src/Internal/Types/PaymentPubKey.purs index cdef8372af..a79dfb05c3 100644 --- a/src/Internal/Types/PaymentPubKey.purs +++ b/src/Internal/Types/PaymentPubKey.purs @@ -6,7 +6,7 @@ module Ctl.Internal.Types.PaymentPubKey import Prelude -import Ctl.Internal.Serialization (publicKeyHash) +import Cardano.Types.PublicKey as PublicKey import Data.Generic.Rep (class Generic) import Data.Newtype (class Newtype, unwrap) import Data.Show.Generic (genericShow) @@ -27,4 +27,4 @@ paymentPubKeyToVkey (PaymentPubKey pk) = Vkey pk paymentPubKeyToRequiredSigner :: PaymentPubKey -> RequiredSigner paymentPubKeyToRequiredSigner (PaymentPubKey pk) = - RequiredSigner <<< publicKeyHash $ unwrap pk + RequiredSigner <<< PublicKey.hash $ unwrap pk diff --git a/src/Internal/Types/PlutusScriptStakeValidator.purs b/src/Internal/Types/PlutusScriptStakeValidator.purs new file mode 100644 index 0000000000..ef10710690 --- /dev/null +++ b/src/Internal/Types/PlutusScriptStakeValidator.purs @@ -0,0 +1,31 @@ +module Ctl.Internal.Types.PlutusScriptStakeValidator + ( PlutusScriptStakeValidator(PlutusScriptStakeValidator) + ) where + +import Prelude + +import Aeson (class DecodeAeson, class EncodeAeson, encodeAeson) +import Cardano.Types.PlutusScript (PlutusScript(PlutusScript)) +import Ctl.Internal.Helpers (decodeTaggedNewtype) +import Data.Generic.Rep (class Generic) +import Data.Newtype (class Newtype) +import Data.Show.Generic (genericShow) + +-- | `PlutusScriptStakeValidator`s are used as validators for withdrawals and +-- | stake address certificates. +newtype PlutusScriptStakeValidator = PlutusScriptStakeValidator PlutusScript + +derive instance Newtype PlutusScriptStakeValidator _ +derive instance Generic PlutusScriptStakeValidator _ +derive instance Eq PlutusScriptStakeValidator + +instance DecodeAeson PlutusScriptStakeValidator where + decodeAeson = decodeTaggedNewtype "getStakeValidator" + PlutusScriptStakeValidator + +instance EncodeAeson PlutusScriptStakeValidator where + encodeAeson (PlutusScriptStakeValidator script) = + encodeAeson { "getStakeValidator": script } + +instance Show PlutusScriptStakeValidator where + show = genericShow diff --git a/src/Internal/Types/ProtocolParameters.purs b/src/Internal/Types/ProtocolParameters.purs index 4a78635594..38c5ae4186 100644 --- a/src/Internal/Types/ProtocolParameters.purs +++ b/src/Internal/Types/ProtocolParameters.purs @@ -1,6 +1,5 @@ module Ctl.Internal.Types.ProtocolParameters ( ProtocolParameters(ProtocolParameters) - , CoinsPerUtxoUnit(CoinsPerUtxoByte, CoinsPerUtxoWord) , CostModelV1 , CostModelV2 , convertPlutusV1CostModel @@ -9,42 +8,30 @@ module Ctl.Internal.Types.ProtocolParameters import Prelude -import Ctl.Internal.Cardano.Types.Transaction - ( Costmdls - , ExUnitPrices - , ExUnits - , Nonce - ) -import Ctl.Internal.Cardano.Types.Transaction as T -import Ctl.Internal.Cardano.Types.Value (Coin) -import Ctl.Internal.Types.Epoch (Epoch) -import Ctl.Internal.Types.Int as Csl +import Cardano.Types.Coin (Coin) +import Cardano.Types.CostModel (CostModel) +import Cardano.Types.Epoch (Epoch) +import Cardano.Types.ExUnitPrices (ExUnitPrices) +import Cardano.Types.ExUnits (ExUnits) +import Cardano.Types.Int as Cardano +import Cardano.Types.Language (Language) import Ctl.Internal.Types.Rational (Rational) import Data.Array (reverse) import Data.Generic.Rep (class Generic) import Data.List (List) import Data.List as List -import Data.Maybe (Maybe) +import Data.Map (Map) import Data.Newtype (class Newtype, wrap) import Data.Show.Generic (genericShow) import Data.Tuple.Nested (type (/\)) import Data.UInt (UInt) import Heterogeneous.Folding (class HFoldl, hfoldl) -data CoinsPerUtxoUnit = CoinsPerUtxoByte Coin | CoinsPerUtxoWord Coin - -derive instance Generic CoinsPerUtxoUnit _ -derive instance Eq CoinsPerUtxoUnit - -instance Show CoinsPerUtxoUnit where - show = genericShow - -- Based on `Cardano.Api.ProtocolParameters.ProtocolParameters` from -- `cardano-api`. newtype ProtocolParameters = ProtocolParameters { protocolVersion :: UInt /\ UInt , decentralization :: Rational - , extraPraosEntropy :: Maybe Nonce , maxBlockHeaderSize :: UInt , maxBlockBodySize :: UInt , maxTxSize :: UInt @@ -58,8 +45,8 @@ newtype ProtocolParameters = ProtocolParameters , poolPledgeInfluence :: Rational , monetaryExpansion :: Rational , treasuryCut :: Rational - , coinsPerUtxoUnit :: CoinsPerUtxoUnit - , costModels :: Costmdls + , coinsPerUtxoByte :: Coin + , costModels :: Map Language CostModel , prices :: ExUnitPrices , maxTxExUnits :: ExUnits , maxBlockExUnits :: ExUnits @@ -77,203 +64,207 @@ instance Show ProtocolParameters where -- | A type that represents a JSON-encoded Costmodel in format used by Ogmios type CostModelV1 = - ( "addInteger-cpu-arguments-intercept" :: Csl.Int - , "addInteger-cpu-arguments-slope" :: Csl.Int - , "addInteger-memory-arguments-intercept" :: Csl.Int - , "addInteger-memory-arguments-slope" :: Csl.Int - , "appendByteString-cpu-arguments-intercept" :: Csl.Int - , "appendByteString-cpu-arguments-slope" :: Csl.Int - , "appendByteString-memory-arguments-intercept" :: Csl.Int - , "appendByteString-memory-arguments-slope" :: Csl.Int - , "appendString-cpu-arguments-intercept" :: Csl.Int - , "appendString-cpu-arguments-slope" :: Csl.Int - , "appendString-memory-arguments-intercept" :: Csl.Int - , "appendString-memory-arguments-slope" :: Csl.Int - , "bData-cpu-arguments" :: Csl.Int - , "bData-memory-arguments" :: Csl.Int - , "blake2b_256-cpu-arguments-intercept" :: Csl.Int - , "blake2b_256-cpu-arguments-slope" :: Csl.Int - , "blake2b_256-memory-arguments" :: Csl.Int - , "cekApplyCost-exBudgetCPU" :: Csl.Int - , "cekApplyCost-exBudgetMemory" :: Csl.Int - , "cekBuiltinCost-exBudgetCPU" :: Csl.Int - , "cekBuiltinCost-exBudgetMemory" :: Csl.Int - , "cekConstCost-exBudgetCPU" :: Csl.Int - , "cekConstCost-exBudgetMemory" :: Csl.Int - , "cekDelayCost-exBudgetCPU" :: Csl.Int - , "cekDelayCost-exBudgetMemory" :: Csl.Int - , "cekForceCost-exBudgetCPU" :: Csl.Int - , "cekForceCost-exBudgetMemory" :: Csl.Int - , "cekLamCost-exBudgetCPU" :: Csl.Int - , "cekLamCost-exBudgetMemory" :: Csl.Int - , "cekStartupCost-exBudgetCPU" :: Csl.Int - , "cekStartupCost-exBudgetMemory" :: Csl.Int - , "cekVarCost-exBudgetCPU" :: Csl.Int - , "cekVarCost-exBudgetMemory" :: Csl.Int - , "chooseData-cpu-arguments" :: Csl.Int - , "chooseData-memory-arguments" :: Csl.Int - , "chooseList-cpu-arguments" :: Csl.Int - , "chooseList-memory-arguments" :: Csl.Int - , "chooseUnit-cpu-arguments" :: Csl.Int - , "chooseUnit-memory-arguments" :: Csl.Int - , "consByteString-cpu-arguments-intercept" :: Csl.Int - , "consByteString-cpu-arguments-slope" :: Csl.Int - , "consByteString-memory-arguments-intercept" :: Csl.Int - , "consByteString-memory-arguments-slope" :: Csl.Int - , "constrData-cpu-arguments" :: Csl.Int - , "constrData-memory-arguments" :: Csl.Int - , "decodeUtf8-cpu-arguments-intercept" :: Csl.Int - , "decodeUtf8-cpu-arguments-slope" :: Csl.Int - , "decodeUtf8-memory-arguments-intercept" :: Csl.Int - , "decodeUtf8-memory-arguments-slope" :: Csl.Int - , "divideInteger-cpu-arguments-constant" :: Csl.Int - , "divideInteger-cpu-arguments-model-arguments-intercept" :: Csl.Int - , "divideInteger-cpu-arguments-model-arguments-slope" :: Csl.Int - , "divideInteger-memory-arguments-intercept" :: Csl.Int - , "divideInteger-memory-arguments-minimum" :: Csl.Int - , "divideInteger-memory-arguments-slope" :: Csl.Int - , "encodeUtf8-cpu-arguments-intercept" :: Csl.Int - , "encodeUtf8-cpu-arguments-slope" :: Csl.Int - , "encodeUtf8-memory-arguments-intercept" :: Csl.Int - , "encodeUtf8-memory-arguments-slope" :: Csl.Int - , "equalsByteString-cpu-arguments-constant" :: Csl.Int - , "equalsByteString-cpu-arguments-intercept" :: Csl.Int - , "equalsByteString-cpu-arguments-slope" :: Csl.Int - , "equalsByteString-memory-arguments" :: Csl.Int - , "equalsData-cpu-arguments-intercept" :: Csl.Int - , "equalsData-cpu-arguments-slope" :: Csl.Int - , "equalsData-memory-arguments" :: Csl.Int - , "equalsInteger-cpu-arguments-intercept" :: Csl.Int - , "equalsInteger-cpu-arguments-slope" :: Csl.Int - , "equalsInteger-memory-arguments" :: Csl.Int - , "equalsString-cpu-arguments-constant" :: Csl.Int - , "equalsString-cpu-arguments-intercept" :: Csl.Int - , "equalsString-cpu-arguments-slope" :: Csl.Int - , "equalsString-memory-arguments" :: Csl.Int - , "fstPair-cpu-arguments" :: Csl.Int - , "fstPair-memory-arguments" :: Csl.Int - , "headList-cpu-arguments" :: Csl.Int - , "headList-memory-arguments" :: Csl.Int - , "iData-cpu-arguments" :: Csl.Int - , "iData-memory-arguments" :: Csl.Int - , "ifThenElse-cpu-arguments" :: Csl.Int - , "ifThenElse-memory-arguments" :: Csl.Int - , "indexByteString-cpu-arguments" :: Csl.Int - , "indexByteString-memory-arguments" :: Csl.Int - , "lengthOfByteString-cpu-arguments" :: Csl.Int - , "lengthOfByteString-memory-arguments" :: Csl.Int - , "lessThanByteString-cpu-arguments-intercept" :: Csl.Int - , "lessThanByteString-cpu-arguments-slope" :: Csl.Int - , "lessThanByteString-memory-arguments" :: Csl.Int - , "lessThanEqualsByteString-cpu-arguments-intercept" :: Csl.Int - , "lessThanEqualsByteString-cpu-arguments-slope" :: Csl.Int - , "lessThanEqualsByteString-memory-arguments" :: Csl.Int - , "lessThanEqualsInteger-cpu-arguments-intercept" :: Csl.Int - , "lessThanEqualsInteger-cpu-arguments-slope" :: Csl.Int - , "lessThanEqualsInteger-memory-arguments" :: Csl.Int - , "lessThanInteger-cpu-arguments-intercept" :: Csl.Int - , "lessThanInteger-cpu-arguments-slope" :: Csl.Int - , "lessThanInteger-memory-arguments" :: Csl.Int - , "listData-cpu-arguments" :: Csl.Int - , "listData-memory-arguments" :: Csl.Int - , "mapData-cpu-arguments" :: Csl.Int - , "mapData-memory-arguments" :: Csl.Int - , "mkCons-cpu-arguments" :: Csl.Int - , "mkCons-memory-arguments" :: Csl.Int - , "mkNilData-cpu-arguments" :: Csl.Int - , "mkNilData-memory-arguments" :: Csl.Int - , "mkNilPairData-cpu-arguments" :: Csl.Int - , "mkNilPairData-memory-arguments" :: Csl.Int - , "mkPairData-cpu-arguments" :: Csl.Int - , "mkPairData-memory-arguments" :: Csl.Int - , "modInteger-cpu-arguments-constant" :: Csl.Int - , "modInteger-cpu-arguments-model-arguments-intercept" :: Csl.Int - , "modInteger-cpu-arguments-model-arguments-slope" :: Csl.Int - , "modInteger-memory-arguments-intercept" :: Csl.Int - , "modInteger-memory-arguments-minimum" :: Csl.Int - , "modInteger-memory-arguments-slope" :: Csl.Int - , "multiplyInteger-cpu-arguments-intercept" :: Csl.Int - , "multiplyInteger-cpu-arguments-slope" :: Csl.Int - , "multiplyInteger-memory-arguments-intercept" :: Csl.Int - , "multiplyInteger-memory-arguments-slope" :: Csl.Int - , "nullList-cpu-arguments" :: Csl.Int - , "nullList-memory-arguments" :: Csl.Int - , "quotientInteger-cpu-arguments-constant" :: Csl.Int - , "quotientInteger-cpu-arguments-model-arguments-intercept" :: Csl.Int - , "quotientInteger-cpu-arguments-model-arguments-slope" :: Csl.Int - , "quotientInteger-memory-arguments-intercept" :: Csl.Int - , "quotientInteger-memory-arguments-minimum" :: Csl.Int - , "quotientInteger-memory-arguments-slope" :: Csl.Int - , "remainderInteger-cpu-arguments-constant" :: Csl.Int - , "remainderInteger-cpu-arguments-model-arguments-intercept" :: Csl.Int - , "remainderInteger-cpu-arguments-model-arguments-slope" :: Csl.Int - , "remainderInteger-memory-arguments-intercept" :: Csl.Int - , "remainderInteger-memory-arguments-minimum" :: Csl.Int - , "remainderInteger-memory-arguments-slope" :: Csl.Int - , "sha2_256-cpu-arguments-intercept" :: Csl.Int - , "sha2_256-cpu-arguments-slope" :: Csl.Int - , "sha2_256-memory-arguments" :: Csl.Int - , "sha3_256-cpu-arguments-intercept" :: Csl.Int - , "sha3_256-cpu-arguments-slope" :: Csl.Int - , "sha3_256-memory-arguments" :: Csl.Int - , "sliceByteString-cpu-arguments-intercept" :: Csl.Int - , "sliceByteString-cpu-arguments-slope" :: Csl.Int - , "sliceByteString-memory-arguments-intercept" :: Csl.Int - , "sliceByteString-memory-arguments-slope" :: Csl.Int - , "sndPair-cpu-arguments" :: Csl.Int - , "sndPair-memory-arguments" :: Csl.Int - , "subtractInteger-cpu-arguments-intercept" :: Csl.Int - , "subtractInteger-cpu-arguments-slope" :: Csl.Int - , "subtractInteger-memory-arguments-intercept" :: Csl.Int - , "subtractInteger-memory-arguments-slope" :: Csl.Int - , "tailList-cpu-arguments" :: Csl.Int - , "tailList-memory-arguments" :: Csl.Int - , "trace-cpu-arguments" :: Csl.Int - , "trace-memory-arguments" :: Csl.Int - , "unBData-cpu-arguments" :: Csl.Int - , "unBData-memory-arguments" :: Csl.Int - , "unConstrData-cpu-arguments" :: Csl.Int - , "unConstrData-memory-arguments" :: Csl.Int - , "unIData-cpu-arguments" :: Csl.Int - , "unIData-memory-arguments" :: Csl.Int - , "unListData-cpu-arguments" :: Csl.Int - , "unListData-memory-arguments" :: Csl.Int - , "unMapData-cpu-arguments" :: Csl.Int - , "unMapData-memory-arguments" :: Csl.Int - , "verifyEd25519Signature-cpu-arguments-intercept" :: Csl.Int - , "verifyEd25519Signature-cpu-arguments-slope" :: Csl.Int - , "verifyEd25519Signature-memory-arguments" :: Csl.Int + ( "addInteger-cpu-arguments-intercept" :: Cardano.Int + , "addInteger-cpu-arguments-slope" :: Cardano.Int + , "addInteger-memory-arguments-intercept" :: Cardano.Int + , "addInteger-memory-arguments-slope" :: Cardano.Int + , "appendByteString-cpu-arguments-intercept" :: Cardano.Int + , "appendByteString-cpu-arguments-slope" :: Cardano.Int + , "appendByteString-memory-arguments-intercept" :: Cardano.Int + , "appendByteString-memory-arguments-slope" :: Cardano.Int + , "appendString-cpu-arguments-intercept" :: Cardano.Int + , "appendString-cpu-arguments-slope" :: Cardano.Int + , "appendString-memory-arguments-intercept" :: Cardano.Int + , "appendString-memory-arguments-slope" :: Cardano.Int + , "bData-cpu-arguments" :: Cardano.Int + , "bData-memory-arguments" :: Cardano.Int + , "blake2b_256-cpu-arguments-intercept" :: Cardano.Int + , "blake2b_256-cpu-arguments-slope" :: Cardano.Int + , "blake2b_256-memory-arguments" :: Cardano.Int + , "cekApplyCost-exBudgetCPU" :: Cardano.Int + , "cekApplyCost-exBudgetMemory" :: Cardano.Int + , "cekBuiltinCost-exBudgetCPU" :: Cardano.Int + , "cekBuiltinCost-exBudgetMemory" :: Cardano.Int + , "cekConstCost-exBudgetCPU" :: Cardano.Int + , "cekConstCost-exBudgetMemory" :: Cardano.Int + , "cekDelayCost-exBudgetCPU" :: Cardano.Int + , "cekDelayCost-exBudgetMemory" :: Cardano.Int + , "cekForceCost-exBudgetCPU" :: Cardano.Int + , "cekForceCost-exBudgetMemory" :: Cardano.Int + , "cekLamCost-exBudgetCPU" :: Cardano.Int + , "cekLamCost-exBudgetMemory" :: Cardano.Int + , "cekStartupCost-exBudgetCPU" :: Cardano.Int + , "cekStartupCost-exBudgetMemory" :: Cardano.Int + , "cekVarCost-exBudgetCPU" :: Cardano.Int + , "cekVarCost-exBudgetMemory" :: Cardano.Int + , "chooseData-cpu-arguments" :: Cardano.Int + , "chooseData-memory-arguments" :: Cardano.Int + , "chooseList-cpu-arguments" :: Cardano.Int + , "chooseList-memory-arguments" :: Cardano.Int + , "chooseUnit-cpu-arguments" :: Cardano.Int + , "chooseUnit-memory-arguments" :: Cardano.Int + , "consByteString-cpu-arguments-intercept" :: Cardano.Int + , "consByteString-cpu-arguments-slope" :: Cardano.Int + , "consByteString-memory-arguments-intercept" :: Cardano.Int + , "consByteString-memory-arguments-slope" :: Cardano.Int + , "constrData-cpu-arguments" :: Cardano.Int + , "constrData-memory-arguments" :: Cardano.Int + , "decodeUtf8-cpu-arguments-intercept" :: Cardano.Int + , "decodeUtf8-cpu-arguments-slope" :: Cardano.Int + , "decodeUtf8-memory-arguments-intercept" :: Cardano.Int + , "decodeUtf8-memory-arguments-slope" :: Cardano.Int + , "divideInteger-cpu-arguments-constant" :: Cardano.Int + , "divideInteger-cpu-arguments-model-arguments-intercept" :: Cardano.Int + , "divideInteger-cpu-arguments-model-arguments-slope" :: Cardano.Int + , "divideInteger-memory-arguments-intercept" :: Cardano.Int + , "divideInteger-memory-arguments-minimum" :: Cardano.Int + , "divideInteger-memory-arguments-slope" :: Cardano.Int + , "encodeUtf8-cpu-arguments-intercept" :: Cardano.Int + , "encodeUtf8-cpu-arguments-slope" :: Cardano.Int + , "encodeUtf8-memory-arguments-intercept" :: Cardano.Int + , "encodeUtf8-memory-arguments-slope" :: Cardano.Int + , "equalsByteString-cpu-arguments-constant" :: Cardano.Int + , "equalsByteString-cpu-arguments-intercept" :: Cardano.Int + , "equalsByteString-cpu-arguments-slope" :: Cardano.Int + , "equalsByteString-memory-arguments" :: Cardano.Int + , "equalsData-cpu-arguments-intercept" :: Cardano.Int + , "equalsData-cpu-arguments-slope" :: Cardano.Int + , "equalsData-memory-arguments" :: Cardano.Int + , "equalsInteger-cpu-arguments-intercept" :: Cardano.Int + , "equalsInteger-cpu-arguments-slope" :: Cardano.Int + , "equalsInteger-memory-arguments" :: Cardano.Int + , "equalsString-cpu-arguments-constant" :: Cardano.Int + , "equalsString-cpu-arguments-intercept" :: Cardano.Int + , "equalsString-cpu-arguments-slope" :: Cardano.Int + , "equalsString-memory-arguments" :: Cardano.Int + , "fstPair-cpu-arguments" :: Cardano.Int + , "fstPair-memory-arguments" :: Cardano.Int + , "headList-cpu-arguments" :: Cardano.Int + , "headList-memory-arguments" :: Cardano.Int + , "iData-cpu-arguments" :: Cardano.Int + , "iData-memory-arguments" :: Cardano.Int + , "ifThenElse-cpu-arguments" :: Cardano.Int + , "ifThenElse-memory-arguments" :: Cardano.Int + , "indexByteString-cpu-arguments" :: Cardano.Int + , "indexByteString-memory-arguments" :: Cardano.Int + , "lengthOfByteString-cpu-arguments" :: Cardano.Int + , "lengthOfByteString-memory-arguments" :: Cardano.Int + , "lessThanByteString-cpu-arguments-intercept" :: Cardano.Int + , "lessThanByteString-cpu-arguments-slope" :: Cardano.Int + , "lessThanByteString-memory-arguments" :: Cardano.Int + , "lessThanEqualsByteString-cpu-arguments-intercept" :: Cardano.Int + , "lessThanEqualsByteString-cpu-arguments-slope" :: Cardano.Int + , "lessThanEqualsByteString-memory-arguments" :: Cardano.Int + , "lessThanEqualsInteger-cpu-arguments-intercept" :: Cardano.Int + , "lessThanEqualsInteger-cpu-arguments-slope" :: Cardano.Int + , "lessThanEqualsInteger-memory-arguments" :: Cardano.Int + , "lessThanInteger-cpu-arguments-intercept" :: Cardano.Int + , "lessThanInteger-cpu-arguments-slope" :: Cardano.Int + , "lessThanInteger-memory-arguments" :: Cardano.Int + , "listData-cpu-arguments" :: Cardano.Int + , "listData-memory-arguments" :: Cardano.Int + , "mapData-cpu-arguments" :: Cardano.Int + , "mapData-memory-arguments" :: Cardano.Int + , "mkCons-cpu-arguments" :: Cardano.Int + , "mkCons-memory-arguments" :: Cardano.Int + , "mkNilData-cpu-arguments" :: Cardano.Int + , "mkNilData-memory-arguments" :: Cardano.Int + , "mkNilPairData-cpu-arguments" :: Cardano.Int + , "mkNilPairData-memory-arguments" :: Cardano.Int + , "mkPairData-cpu-arguments" :: Cardano.Int + , "mkPairData-memory-arguments" :: Cardano.Int + , "modInteger-cpu-arguments-constant" :: Cardano.Int + , "modInteger-cpu-arguments-model-arguments-intercept" :: Cardano.Int + , "modInteger-cpu-arguments-model-arguments-slope" :: Cardano.Int + , "modInteger-memory-arguments-intercept" :: Cardano.Int + , "modInteger-memory-arguments-minimum" :: Cardano.Int + , "modInteger-memory-arguments-slope" :: Cardano.Int + , "multiplyInteger-cpu-arguments-intercept" :: Cardano.Int + , "multiplyInteger-cpu-arguments-slope" :: Cardano.Int + , "multiplyInteger-memory-arguments-intercept" :: Cardano.Int + , "multiplyInteger-memory-arguments-slope" :: Cardano.Int + , "nullList-cpu-arguments" :: Cardano.Int + , "nullList-memory-arguments" :: Cardano.Int + , "quotientInteger-cpu-arguments-constant" :: Cardano.Int + , "quotientInteger-cpu-arguments-model-arguments-intercept" :: Cardano.Int + , "quotientInteger-cpu-arguments-model-arguments-slope" :: Cardano.Int + , "quotientInteger-memory-arguments-intercept" :: Cardano.Int + , "quotientInteger-memory-arguments-minimum" :: Cardano.Int + , "quotientInteger-memory-arguments-slope" :: Cardano.Int + , "remainderInteger-cpu-arguments-constant" :: Cardano.Int + , "remainderInteger-cpu-arguments-model-arguments-intercept" :: Cardano.Int + , "remainderInteger-cpu-arguments-model-arguments-slope" :: Cardano.Int + , "remainderInteger-memory-arguments-intercept" :: Cardano.Int + , "remainderInteger-memory-arguments-minimum" :: Cardano.Int + , "remainderInteger-memory-arguments-slope" :: Cardano.Int + , "sha2_256-cpu-arguments-intercept" :: Cardano.Int + , "sha2_256-cpu-arguments-slope" :: Cardano.Int + , "sha2_256-memory-arguments" :: Cardano.Int + , "sha3_256-cpu-arguments-intercept" :: Cardano.Int + , "sha3_256-cpu-arguments-slope" :: Cardano.Int + , "sha3_256-memory-arguments" :: Cardano.Int + , "sliceByteString-cpu-arguments-intercept" :: Cardano.Int + , "sliceByteString-cpu-arguments-slope" :: Cardano.Int + , "sliceByteString-memory-arguments-intercept" :: Cardano.Int + , "sliceByteString-memory-arguments-slope" :: Cardano.Int + , "sndPair-cpu-arguments" :: Cardano.Int + , "sndPair-memory-arguments" :: Cardano.Int + , "subtractInteger-cpu-arguments-intercept" :: Cardano.Int + , "subtractInteger-cpu-arguments-slope" :: Cardano.Int + , "subtractInteger-memory-arguments-intercept" :: Cardano.Int + , "subtractInteger-memory-arguments-slope" :: Cardano.Int + , "tailList-cpu-arguments" :: Cardano.Int + , "tailList-memory-arguments" :: Cardano.Int + , "trace-cpu-arguments" :: Cardano.Int + , "trace-memory-arguments" :: Cardano.Int + , "unBData-cpu-arguments" :: Cardano.Int + , "unBData-memory-arguments" :: Cardano.Int + , "unConstrData-cpu-arguments" :: Cardano.Int + , "unConstrData-memory-arguments" :: Cardano.Int + , "unIData-cpu-arguments" :: Cardano.Int + , "unIData-memory-arguments" :: Cardano.Int + , "unListData-cpu-arguments" :: Cardano.Int + , "unListData-memory-arguments" :: Cardano.Int + , "unMapData-cpu-arguments" :: Cardano.Int + , "unMapData-memory-arguments" :: Cardano.Int + , "verifyEd25519Signature-cpu-arguments-intercept" :: Cardano.Int + , "verifyEd25519Signature-cpu-arguments-slope" :: Cardano.Int + , "verifyEd25519Signature-memory-arguments" :: Cardano.Int ) type CostModelV2 = - ( "serialiseData-cpu-arguments-intercept" :: Csl.Int - , "serialiseData-cpu-arguments-slope" :: Csl.Int - , "serialiseData-memory-arguments-intercept" :: Csl.Int - , "serialiseData-memory-arguments-slope" :: Csl.Int - , "verifyEcdsaSecp256k1Signature-cpu-arguments" :: Csl.Int - , "verifyEcdsaSecp256k1Signature-memory-arguments" :: Csl.Int - , "verifySchnorrSecp256k1Signature-cpu-arguments-intercept" :: Csl.Int - , "verifySchnorrSecp256k1Signature-cpu-arguments-slope" :: Csl.Int - , "verifySchnorrSecp256k1Signature-memory-arguments" :: Csl.Int + ( "serialiseData-cpu-arguments-intercept" :: Cardano.Int + , "serialiseData-cpu-arguments-slope" :: Cardano.Int + , "serialiseData-memory-arguments-intercept" :: Cardano.Int + , "serialiseData-memory-arguments-slope" :: Cardano.Int + , "verifyEcdsaSecp256k1Signature-cpu-arguments" :: Cardano.Int + , "verifyEcdsaSecp256k1Signature-memory-arguments" :: Cardano.Int + , "verifySchnorrSecp256k1Signature-cpu-arguments-intercept" :: Cardano.Int + , "verifySchnorrSecp256k1Signature-cpu-arguments-slope" :: Cardano.Int + , "verifySchnorrSecp256k1Signature-memory-arguments" :: Cardano.Int | CostModelV1 ) -- This assumes that cost models are stored in lexicographical order convertCostModel :: forall costModel - . HFoldl (List Csl.Int -> Csl.Int -> List Csl.Int) (List Csl.Int) costModel - (List Csl.Int) + . HFoldl (List Cardano.Int -> Cardano.Int -> List Cardano.Int) + (List Cardano.Int) + costModel + (List Cardano.Int) => costModel - -> T.CostModel + -> CostModel convertCostModel model = wrap $ reverse $ List.toUnfoldable $ hfoldl - ((\xs x -> x List.: xs) :: List Csl.Int -> Csl.Int -> List Csl.Int) - (mempty :: List Csl.Int) + ( (\xs x -> x List.: xs) + :: List Cardano.Int -> Cardano.Int -> List Cardano.Int + ) + (mempty :: List Cardano.Int) model -- Specialized conversions to only perform the type level traversals once -convertPlutusV1CostModel :: Record CostModelV1 -> T.CostModel +convertPlutusV1CostModel :: Record CostModelV1 -> CostModel convertPlutusV1CostModel = convertCostModel -convertPlutusV2CostModel :: Record CostModelV2 -> T.CostModel +convertPlutusV2CostModel :: Record CostModelV2 -> CostModel convertPlutusV2CostModel = convertCostModel diff --git a/src/Internal/Types/Rational.purs b/src/Internal/Types/Rational.purs index e0d101aaf5..69a92563f7 100644 --- a/src/Internal/Types/Rational.purs +++ b/src/Internal/Types/Rational.purs @@ -6,7 +6,6 @@ module Ctl.Internal.Types.Rational , recip , numerator , denominator - , denominatorAsNat ) where import Prelude @@ -20,12 +19,10 @@ import Aeson , toStringifiedNumbersJson , (.:) ) +import Cardano.FromData (class FromData) +import Cardano.ToData (class ToData) import Cardano.Types.BigNum as BigNum import Cardano.Types.PlutusData (PlutusData(Constr, Integer)) -import Ctl.Internal.FromData (class FromData) -import Ctl.Internal.ToData (class ToData) -import Ctl.Internal.Types.Natural (Natural) -import Ctl.Internal.Types.Natural (fromBigInt', toBigInt) as Nat import Data.Either (Either(Left)) import Data.Maybe (Maybe(Just, Nothing), maybe) import Data.Ratio (Ratio) @@ -92,11 +89,6 @@ numerator (Rational r) = Ratio.numerator r denominator :: Rational -> BigInt denominator (Rational r) = Ratio.denominator r --- This is safe because the denominator is guaranteed to be positive. --- | Get the denominator of a `Rational` as `Natural`. -denominatorAsNat :: Rational -> Natural -denominatorAsNat = Nat.fromBigInt' <<< denominator - -------------------------------------------------------------------------------- -- FromData / ToData -------------------------------------------------------------------------------- @@ -132,6 +124,3 @@ instance RationalComponent BigInt where instance RationalComponent Int where reduce n d = reduce (BigInt.fromInt n) (BigInt.fromInt d) - -instance RationalComponent Natural where - reduce n d = reduce (Nat.toBigInt n) (Nat.toBigInt d) diff --git a/src/Internal/Types/RawBytes.purs b/src/Internal/Types/RawBytes.purs index 897be26bd0..9c03ed4944 100644 --- a/src/Internal/Types/RawBytes.purs +++ b/src/Internal/Types/RawBytes.purs @@ -17,8 +17,8 @@ module Ctl.Internal.Types.RawBytes import Prelude import Aeson (class DecodeAeson, class EncodeAeson) -import Ctl.Internal.Metadata.FromMetadata (class FromMetadata) -import Ctl.Internal.Metadata.ToMetadata (class ToMetadata) +import Cardano.FromMetadata (class FromMetadata) +import Cardano.ToMetadata (class ToMetadata) import Data.ByteArray (ByteArray) import Data.ByteArray as BytesArray import Data.Maybe (Maybe) diff --git a/src/Internal/Types/RedeemerTag.purs b/src/Internal/Types/RedeemerTag.purs index d1f40211bb..bd6cf2ac65 100644 --- a/src/Internal/Types/RedeemerTag.purs +++ b/src/Internal/Types/RedeemerTag.purs @@ -1,18 +1,9 @@ module Ctl.Internal.Types.RedeemerTag - ( RedeemerTag(Spend, Mint, Cert, Reward) - , fromString + ( fromString ) where -import Prelude - -import Aeson (class EncodeAeson) -import Ctl.Internal.Helpers (encodeTagged') -import Data.Generic.Rep (class Generic) +import Cardano.Types.RedeemerTag (RedeemerTag(..)) import Data.Maybe (Maybe(Just, Nothing)) -import Data.Show.Generic (genericShow) - --- lives in it's own module due to a name conflict with the `Mint` Type -data RedeemerTag = Spend | Mint | Cert | Reward fromString :: String -> Maybe RedeemerTag fromString = case _ of @@ -21,17 +12,3 @@ fromString = case _ of "certificate" -> Just Cert "withdrawal" -> Just Reward _ -> Nothing - -derive instance Generic RedeemerTag _ -derive instance Eq RedeemerTag -derive instance Ord RedeemerTag - -instance Show RedeemerTag where - show = genericShow - -instance EncodeAeson RedeemerTag where - encodeAeson = case _ of - Spend -> encodeTagged' "Spend" {} - Mint -> encodeTagged' "Mint" {} - Cert -> encodeTagged' "Cert" {} - Reward -> encodeTagged' "Reward" {} diff --git a/src/Internal/Types/ScriptLookups.purs b/src/Internal/Types/ScriptLookups.purs index 3b5abda7be..73ad014ed3 100644 --- a/src/Internal/Types/ScriptLookups.purs +++ b/src/Internal/Types/ScriptLookups.purs @@ -15,13 +15,20 @@ module Ctl.Internal.Types.ScriptLookups import Prelude hiding (join) +import Cardano.Types + ( DataHash + , PaymentPubKeyHash + , PlutusData + , PublicKey + , StakePubKeyHash + , TransactionOutput + , UtxoMap + ) +import Cardano.Types.DataHash (hashPlutusData) import Cardano.Types.TransactionInput (TransactionInput) -import Ctl.Internal.Hashing (datumHash) as Hashing import Ctl.Internal.Helpers ((<\>)) -import Ctl.Internal.Plutus.Types.Transaction (TransactionOutputWithRefScript) as Plutus -import Ctl.Internal.Types.Datum (DataHash, Datum) -import Ctl.Internal.Types.PaymentPubKey (PaymentPubKey) -import Ctl.Internal.Types.Scripts (MintingPolicy, Validator) +import Ctl.Internal.Types.MintingPolicy (MintingPolicy) +import Ctl.Internal.Types.Validator (Validator) import Data.Array (singleton, union) as Array import Data.Generic.Rep (class Generic) import Data.Map (Map, empty, singleton, union) @@ -45,17 +52,15 @@ import Data.Show.Generic (genericShow) -- The lookups uses the Plutus type `TransactionOutput` and does internal -- conversions to the Serialization/Cardano to append to the `TxBody` as needed. newtype ScriptLookups = ScriptLookups - { mps :: + { mintingPolicies :: Array MintingPolicy -- Minting policies that the script interacts with - , txOutputs :: - Map TransactionInput Plutus.TransactionOutputWithRefScript -- Unspent outputs that the script may want to spend - , scripts :: - Array Validator -- Script validators - , datums :: Map DataHash Datum -- Datums that we might need + , txOutputs :: UtxoMap + , scripts :: Array Validator -- Script validators + , datums :: Map DataHash PlutusData -- Datums that we might need -- FIXME there's currently no way to set this field -- See https://github.com/Plutonomicon/cardano-transaction-lib/issues/569 , paymentPubKeyHashes :: - Map PaymentPubKeyHash PaymentPubKey -- Public keys that we might need + Map PaymentPubKeyHash PublicKey -- Public keys that we might need , ownPaymentPubKeyHash :: Maybe PaymentPubKeyHash -- The contract's payment public key hash, used for depositing tokens etc. , ownStakePubKeyHash :: @@ -74,7 +79,7 @@ instance Show ScriptLookups where instance Semigroup ScriptLookups where append (ScriptLookups l) (ScriptLookups r) = ScriptLookups - { mps: l.mps `Array.union` r.mps + { mintingPolicies: l.mintingPolicies `Array.union` r.mintingPolicies , txOutputs: l.txOutputs `union` r.txOutputs , scripts: l.scripts `Array.union` r.scripts , datums: l.datums `union` r.datums @@ -86,7 +91,7 @@ instance Semigroup ScriptLookups where instance Monoid ScriptLookups where mempty = ScriptLookups - { mps: mempty + { mintingPolicies: mempty , txOutputs: empty , scripts: mempty , datums: empty @@ -103,7 +108,7 @@ instance Monoid ScriptLookups where -- | input constraints. unspentOutputs :: forall (a :: Type) - . Map TransactionInput Plutus.TransactionOutputWithRefScript + . Map TransactionInput TransactionOutput -> ScriptLookups unspentOutputs mp = over ScriptLookups _ { txOutputs = mp } mempty @@ -111,13 +116,14 @@ unspentOutputs mp = over ScriptLookups _ { txOutputs = mp } mempty -- | This should not fail. unspentOutputsM :: forall (a :: Type) - . Map TransactionInput Plutus.TransactionOutputWithRefScript + . Map TransactionInput TransactionOutput -> Maybe ScriptLookups unspentOutputsM = pure <<< unspentOutputs -- | A script lookups value with a minting policy script. mintingPolicy :: MintingPolicy -> ScriptLookups -mintingPolicy pl = over ScriptLookups _ { mps = Array.singleton pl } mempty +mintingPolicy pl = over ScriptLookups _ { mintingPolicies = Array.singleton pl } + mempty -- | Same as `mintingPolicy` but in `Maybe` context for convenience. This -- | should not fail. @@ -135,9 +141,9 @@ validatorM :: forall (a :: Type). Validator -> Maybe ScriptLookups validatorM = pure <<< validator -- | A script lookups value with a datum. -datum :: Datum -> ScriptLookups +datum :: PlutusData -> ScriptLookups datum dt = - over ScriptLookups _ { datums = singleton (Hashing.datumHash dt) dt } mempty + over ScriptLookups _ { datums = singleton (hashPlutusData dt) dt } mempty -- | Add your own `PaymentPubKeyHash` to the lookup. ownPaymentPubKeyHash :: PaymentPubKeyHash -> ScriptLookups diff --git a/src/Internal/Types/Scripts.purs b/src/Internal/Types/Scripts.purs deleted file mode 100644 index 9b015a2ddf..0000000000 --- a/src/Internal/Types/Scripts.purs +++ /dev/null @@ -1,177 +0,0 @@ -module Ctl.Internal.Types.Scripts - ( MintingPolicy(PlutusMintingPolicy, NativeMintingPolicy) - , MintingPolicyHash(MintingPolicyHash) - , PlutusScriptStakeValidator(PlutusScriptStakeValidator) - , NativeScriptStakeValidator(NativeScriptStakeValidator) - , StakeValidatorHash(StakeValidatorHash) - , Validator(Validator) - , ValidatorHash(ValidatorHash) - ) where - -import Prelude - -import Aeson - ( class DecodeAeson - , class EncodeAeson - , Aeson - , JsonDecodeError(TypeMismatch) - , caseAesonObject - , decodeAeson - , encodeAeson - , getField - ) -import Cardano.FromData (class FromData) -import Cardano.FromMetadata (class FromMetadata) -import Cardano.ToData (class ToData) -import Cardano.ToMetadata (class ToMetadata) -import Cardano.Types.NativeScript (NativeScript) -import Cardano.Types.PlutusScript (PlutusScript(..)) -import Control.Alt ((<|>)) -import Cardano.Types.ScriptHash (ScriptHash) -import Data.Either (Either(Left)) -import Data.Generic.Rep (class Generic) -import Data.Newtype (class Newtype) -import Data.Show.Generic (genericShow) - --------------------------------------------------------------------------------- --- `PlutusScript` newtypes and `TypedValidator` --------------------------------------------------------------------------------- - -decodeAesonHelper - :: ∀ (a :: Type) (b :: Type) - . DecodeAeson a - => String - -> (a -> b) - -> Aeson - -> Either JsonDecodeError b -decodeAesonHelper constrName constr = caseAesonObject - (Left $ TypeMismatch "Expected object") - (flip getField constrName >=> decodeAeson >>> map constr) - --- | `MintingPolicy` is a sum type of `PlutusScript` and `NativeScript` which are used as --- | validators for minting constraints. -data MintingPolicy - = PlutusMintingPolicy PlutusScript - | NativeMintingPolicy NativeScript - -derive instance Generic MintingPolicy _ -derive instance Eq MintingPolicy - -instance DecodeAeson MintingPolicy where - decodeAeson aes = - decodeAesonHelper "getPlutusMintingPolicy" PlutusMintingPolicy aes <|> - decodeAesonHelper "getNativeMintingPolicy" NativeMintingPolicy aes - -instance EncodeAeson MintingPolicy where - encodeAeson (NativeMintingPolicy nscript) = - encodeAeson { "getNativeMintingPolicy": nscript } - encodeAeson (PlutusMintingPolicy script) = - encodeAeson { "getPlutusMintingPolicy": script } - -instance Show MintingPolicy where - show = genericShow - -newtype Validator = Validator PlutusScript - -derive instance Generic Validator _ -derive instance Newtype Validator _ -derive newtype instance Eq Validator -derive newtype instance Ord Validator - -instance DecodeAeson Validator where - decodeAeson = decodeAesonHelper "getValidator" Validator - -instance EncodeAeson Validator where - encodeAeson (Validator script) = - encodeAeson { "getValidator": script } - -instance Show Validator where - show = genericShow - --- | `NativeScriptStakeValidator`s are used as validators for withdrawals and --- | stake address certificates. -newtype NativeScriptStakeValidator = NativeScriptStakeValidator NativeScript - -derive instance Newtype NativeScriptStakeValidator _ -derive instance Generic NativeScriptStakeValidator _ -derive instance Eq NativeScriptStakeValidator - -instance Show NativeScriptStakeValidator where - show = genericShow - --- | `PlutusScriptStakeValidator`s are used as validators for withdrawals and --- | stake address certificates. -newtype PlutusScriptStakeValidator = PlutusScriptStakeValidator PlutusScript - -derive instance Newtype PlutusScriptStakeValidator _ -derive instance Generic PlutusScriptStakeValidator _ -derive instance Eq PlutusScriptStakeValidator - -instance DecodeAeson PlutusScriptStakeValidator where - decodeAeson = decodeAesonHelper "getStakeValidator" PlutusScriptStakeValidator - -instance EncodeAeson PlutusScriptStakeValidator where - encodeAeson (PlutusScriptStakeValidator script) = - encodeAeson { "getStakeValidator": script } - -instance Show PlutusScriptStakeValidator where - show = genericShow - --------------------------------------------------------------------------------- --- `ScriptHash` newtypes --------------------------------------------------------------------------------- -newtype MintingPolicyHash = MintingPolicyHash ScriptHash - -derive instance Generic MintingPolicyHash _ -derive instance Newtype MintingPolicyHash _ -derive newtype instance Eq MintingPolicyHash -derive newtype instance Ord MintingPolicyHash -derive newtype instance FromData MintingPolicyHash -derive newtype instance ToData MintingPolicyHash -derive newtype instance FromMetadata MintingPolicyHash -derive newtype instance ToMetadata MintingPolicyHash - -instance DecodeAeson MintingPolicyHash where - decodeAeson = decodeAesonHelper "getMintingPolicyHash" MintingPolicyHash - -instance EncodeAeson MintingPolicyHash where - encodeAeson (MintingPolicyHash hash) = - encodeAeson { "getMintingPolicyHash": hash } - -instance Show MintingPolicyHash where - show = genericShow - -newtype ValidatorHash = ValidatorHash ScriptHash - -derive instance Generic ValidatorHash _ -derive instance Newtype ValidatorHash _ -derive newtype instance Eq ValidatorHash -derive newtype instance Ord ValidatorHash -derive newtype instance FromData ValidatorHash -derive newtype instance ToData ValidatorHash -derive newtype instance FromMetadata ValidatorHash -derive newtype instance ToMetadata ValidatorHash -derive newtype instance EncodeAeson ValidatorHash -derive newtype instance DecodeAeson ValidatorHash - -instance Show ValidatorHash where - show = genericShow - -newtype StakeValidatorHash = StakeValidatorHash ScriptHash - -derive instance Generic StakeValidatorHash _ -derive instance Newtype StakeValidatorHash _ -derive newtype instance Eq StakeValidatorHash -derive newtype instance Ord StakeValidatorHash -derive newtype instance ToData StakeValidatorHash -derive newtype instance FromData StakeValidatorHash - -instance DecodeAeson StakeValidatorHash where - decodeAeson = decodeAesonHelper "getStakeValidatorHash" StakeValidatorHash - -instance EncodeAeson StakeValidatorHash where - encodeAeson (StakeValidatorHash hash) = - encodeAeson { "getStakeValidatorHash": hash } - -instance Show StakeValidatorHash where - show = genericShow diff --git a/src/Internal/Types/StakeValidatorHash.purs b/src/Internal/Types/StakeValidatorHash.purs new file mode 100644 index 0000000000..ebacb2dcfa --- /dev/null +++ b/src/Internal/Types/StakeValidatorHash.purs @@ -0,0 +1,33 @@ +module Ctl.Internal.Types.StakeValidatorHash + ( StakeValidatorHash(StakeValidatorHash) + ) where + +import Prelude + +import Aeson (class DecodeAeson, class EncodeAeson, encodeAeson) +import Cardano.FromData (class FromData) +import Cardano.ToData (class ToData) +import Cardano.Types.ScriptHash (ScriptHash) +import Ctl.Internal.Helpers (decodeTaggedNewtype) +import Data.Generic.Rep (class Generic) +import Data.Newtype (class Newtype) +import Data.Show.Generic (genericShow) + +newtype StakeValidatorHash = StakeValidatorHash ScriptHash + +derive instance Generic StakeValidatorHash _ +derive instance Newtype StakeValidatorHash _ +derive newtype instance Eq StakeValidatorHash +derive newtype instance Ord StakeValidatorHash +derive newtype instance ToData StakeValidatorHash +derive newtype instance FromData StakeValidatorHash + +instance DecodeAeson StakeValidatorHash where + decodeAeson = decodeTaggedNewtype "getStakeValidatorHash" StakeValidatorHash + +instance EncodeAeson StakeValidatorHash where + encodeAeson (StakeValidatorHash hash) = + encodeAeson { "getStakeValidatorHash": hash } + +instance Show StakeValidatorHash where + show = genericShow diff --git a/src/Internal/Types/SystemStart.purs b/src/Internal/Types/SystemStart.purs index 80e37b524d..72bf8d2c17 100644 --- a/src/Internal/Types/SystemStart.purs +++ b/src/Internal/Types/SystemStart.purs @@ -71,4 +71,3 @@ ogmiosDateTimeFormatStringMsec = ogmiosDateTimeFormatStringSec <> ".SSS" ogmiosDateTimeFormatStringMsecUTC :: String ogmiosDateTimeFormatStringMsecUTC = ogmiosDateTimeFormatStringMsec <> "Z" - diff --git a/src/Internal/Types/TxConstraints.purs b/src/Internal/Types/TxConstraints.purs index 3498c8e00b..a581abac82 100644 --- a/src/Internal/Types/TxConstraints.purs +++ b/src/Internal/Types/TxConstraints.purs @@ -36,7 +36,6 @@ module Ctl.Internal.Types.TxConstraints , MustWithdrawStakePubKey ) , TxConstraints(TxConstraints) - , isSatisfiable , mustBeSignedBy , mustDelegateStakeNativeScript , mustDelegateStakePlutusScript @@ -69,7 +68,6 @@ module Ctl.Internal.Types.TxConstraints , mustPayToScriptAddressWithScriptRef , mustPayToScriptWithScriptRef , mustProduceAtLeast - , mustProduceAtLeastTotal , mustReferenceOutput , mustRegisterPool , mustRegisterStakePubKey @@ -77,7 +75,6 @@ module Ctl.Internal.Types.TxConstraints , mustRetirePool , mustSatisfyAnyOf , mustSpendAtLeast - , mustSpendAtLeastTotal , mustSpendNativeScriptOutput , mustSpendPubKeyOutput , mustSpendScriptOutput @@ -86,63 +83,49 @@ module Ctl.Internal.Types.TxConstraints , mustWithdrawStakeNativeScript , mustWithdrawStakePlutusScript , mustWithdrawStakePubKey - , pubKeyPayments - , requiredDatums - , requiredMonetaryPolicies - , requiredSignatories , singleton , utxoWithScriptRef ) where import Prelude hiding (join) -import Cardano.Types.AssetName (AssetName) -import Cardano.Types.BigNum (BigNum(..)) -import Cardano.Types.MultiAsset as MultiAsset -import Cardano.Types.PaymentPubKeyHash (PaymentPubKeyHash(..)) -import Cardano.Types.PlutusData (PlutusData) -import Cardano.Types.ScriptHash (ScriptHash(..)) -import Cardano.Types.StakePubKeyHash (StakePubKeyHash(..)) -import Ctl.Internal.Cardano.Types.NativeScript (NativeScript) -import Ctl.Internal.Cardano.Types.ScriptRef (ScriptRef) -import Ctl.Internal.Cardano.Types.Transaction - ( Epoch +import Cardano.Types + ( AssetName + , BigNum + , Credential + , DataHash + , Epoch + , MultiAsset + , NativeScript + , PaymentPubKeyHash + , PlutusData , PoolPubKeyHash - , PoolRegistrationParams + , ScriptHash + , ScriptRef + , StakePubKeyHash + , TransactionInput + , TransactionOutput + , TransactionUnspentOutput(TransactionUnspentOutput) + , Value ) -import Ctl.Internal.Helpers (notImplemented) +import Cardano.Types.MultiAsset as MultiAsset import Ctl.Internal.NativeScripts (NativeScriptHash) -import Ctl.Internal.Plutus.Types.Credential (Credential) -import Ctl.Internal.Plutus.Types.CurrencySymbol - ( CurrencySymbol - , currencyMPSHash +import Ctl.Internal.Types.Interval (POSIXTimeRange) +import Ctl.Internal.Types.MintingPolicyHash (MintingPolicyHash) +import Ctl.Internal.Types.NativeScriptStakeValidator + ( NativeScriptStakeValidator ) -import Ctl.Internal.Plutus.Types.Transaction (TransactionOutputWithRefScript) -import Ctl.Internal.Plutus.Types.TransactionUnspentOutput - ( TransactionUnspentOutput(TransactionUnspentOutput) - ) -import Ctl.Internal.Plutus.Types.Value (Value, flattenMultiAssets) -import Ctl.Internal.Types.Datum (Datum) -import Ctl.Internal.Types.Interval - ( POSIXTimeRange - , always - , intersection - , isEmpty +import Ctl.Internal.Types.PlutusScriptStakeValidator + ( PlutusScriptStakeValidator ) +import Ctl.Internal.Types.PoolRegistrationParams (PoolRegistrationParams) import Ctl.Internal.Types.Redeemer (Redeemer, unitRedeemer) -import Ctl.Internal.Types.Scripts - ( MintingPolicyHash - , NativeScriptStakeValidator - , PlutusScriptStakeValidator - , StakeValidatorHash - , ValidatorHash - ) -import Ctl.Internal.Types.Transaction (DataHash, TransactionInput) +import Ctl.Internal.Types.StakeValidatorHash (StakeValidatorHash) +import Ctl.Internal.Types.ValidatorHash (ValidatorHash) import Data.Array as Array -import Data.Foldable (class Foldable, foldMap, foldl, foldr) +import Data.Foldable (class Foldable) import Data.Generic.Rep (class Generic) -import Data.Lattice (join) -import Data.Map (Map, fromFoldableWith, toUnfoldable) +import Data.Map (Map) import Data.Map (singleton) as Map import Data.Maybe (Maybe(Just, Nothing)) import Data.Monoid (guard) @@ -160,7 +143,7 @@ import Prim.TypeError (class Warn, Text) -- | Constraints on transactions that want to spend script outputs data TxConstraint - = MustIncludeDatum Datum + = MustIncludeDatum PlutusData | MustValidateIn POSIXTimeRange | MustBeSignedBy PaymentPubKeyHash | MustSpendAtLeast Value @@ -173,14 +156,14 @@ data TxConstraint (Maybe InputWithScriptRef) | MustMintValueUsingNativeScript NativeScript AssetName BigNum | MustPayToPubKeyAddress PaymentPubKeyHash (Maybe StakePubKeyHash) - (Maybe (Datum /\ DatumPresence)) + (Maybe (PlutusData /\ DatumPresence)) (Maybe ScriptRef) Value | MustPayToNativeScript NativeScriptHash (Maybe Credential) Value - | MustPayToScript ValidatorHash (Maybe Credential) Datum DatumPresence + | MustPayToScript ValidatorHash (Maybe Credential) PlutusData DatumPresence (Maybe ScriptRef) Value - | MustHashDatum DataHash Datum + | MustHashDatum DataHash PlutusData | MustRegisterStakePubKey StakePubKeyHash | MustDeregisterStakePubKey StakePubKeyHash | MustRegisterStakeScript StakeValidatorHash @@ -222,7 +205,7 @@ instance Show InputWithScriptRef where show = genericShow utxoWithScriptRef - :: InputWithScriptRef -> Map TransactionInput TransactionOutputWithRefScript + :: InputWithScriptRef -> Map TransactionInput TransactionOutput utxoWithScriptRef inputWithRefScript = Map.singleton input output where TransactionUnspentOutput { input, output } = @@ -305,7 +288,7 @@ mustBeSignedBy mustBeSignedBy = singleton <<< MustBeSignedBy -- | Require the transaction to include a datum. -mustIncludeDatum :: Datum -> TxConstraints +mustIncludeDatum :: PlutusData -> TxConstraints mustIncludeDatum = singleton <<< MustIncludeDatum -- | Require the transaction to reference (not spend!) the given unspent @@ -327,7 +310,7 @@ mustPayToPubKeyAddress pkh skh = mustPayToPubKeyAddressWithDatum :: PaymentPubKeyHash -> StakePubKeyHash - -> Datum + -> PlutusData -> DatumPresence -> Value -> TxConstraints @@ -349,7 +332,7 @@ mustPayToPubKeyAddressWithScriptRef pkh skh scriptRef = mustPayToPubKeyAddressWithDatumAndScriptRef :: PaymentPubKeyHash -> StakePubKeyHash - -> Datum + -> PlutusData -> DatumPresence -> ScriptRef -> Value @@ -373,7 +356,7 @@ mustPayToPubKey pkh = -- | Lock the value and datum with a payment public key hash. mustPayToPubKeyWithDatum :: PaymentPubKeyHash - -> Datum + -> PlutusData -> DatumPresence -> Value -> TxConstraints @@ -392,7 +375,7 @@ mustPayToPubKeyWithScriptRef pkh scriptRef = -- | Lock the value, datum and reference script with a payment public key hash. mustPayToPubKeyWithDatumAndScriptRef :: PaymentPubKeyHash - -> Datum + -> PlutusData -> DatumPresence -> ScriptRef -> Value @@ -408,7 +391,7 @@ mustPayToPubKeyWithDatumAndScriptRef pkh datum dtp scriptRef = -- | the transaction. mustPayToScript :: ValidatorHash - -> Datum + -> PlutusData -> DatumPresence -> Value -> TxConstraints @@ -419,7 +402,7 @@ mustPayToScript vh dt dtp vl = mustPayToScriptAddress :: ValidatorHash -> Credential - -> Datum + -> PlutusData -> DatumPresence -> Value -> TxConstraints @@ -432,7 +415,7 @@ mustPayToScriptAddress vh credential dt dtp vl = -- | control the spending of the output, i.e. both scripts can be different. mustPayToScriptWithScriptRef :: ValidatorHash - -> Datum + -> PlutusData -> DatumPresence -> ScriptRef -> Value @@ -448,7 +431,7 @@ mustPayToScriptAddressWithScriptRef :: forall (i :: Type) (o :: Type) . ValidatorHash -> Credential - -> Datum + -> PlutusData -> DatumPresence -> ScriptRef -> Value @@ -476,7 +459,7 @@ mustPayToNativeScriptAddress nsHash credential vl = -- | Mint the given `Value` -- | The amount to mint must not be zero. -mustMintValue :: Value -> TxConstraints +mustMintValue :: MultiAsset -> TxConstraints mustMintValue = mustMintValueWithRedeemer unitRedeemer -- | Mint the given `Value` by accessing non-Ada assets. @@ -484,16 +467,15 @@ mustMintValue = mustMintValueWithRedeemer unitRedeemer mustMintValueWithRedeemer :: forall (i :: Type) (o :: Type) . Redeemer - -> Value + -> MultiAsset -> TxConstraints -mustMintValueWithRedeemer redeemer = notImplemented -- TODO: replace with MultiAsset - --- Array.fold <<< map tokenConstraint <<< MultiAsset.flatten --- where --- tokenConstraint --- :: ScriptHash /\ AssetName /\ BigNum -> TxConstraints --- tokenConstraint (cs /\ tn /\ amount) = --- mustMintCurrencyWithRedeemer (wrap cs) redeemer tn amount +mustMintValueWithRedeemer redeemer = + Array.fold <<< map tokenConstraint <<< MultiAsset.flatten + where + tokenConstraint + :: ScriptHash /\ AssetName /\ BigNum -> TxConstraints + tokenConstraint (cs /\ tn /\ amount) = + mustMintCurrencyWithRedeemer (wrap cs) redeemer tn amount -- | Create the given amount of the currency. -- | The amount to mint must not be zero. @@ -594,7 +576,7 @@ mustSpendNativeScriptOutput txOutRef = singleton <<< MustSpendNativeScriptOutput txOutRef mustHashDatum - :: DataHash -> Datum -> TxConstraints + :: DataHash -> PlutusData -> TxConstraints mustHashDatum dhsh = singleton <<< MustHashDatum dhsh mustRegisterStakePubKey @@ -698,75 +680,3 @@ mustSatisfyAnyOf = -- | chain and collateral will be lost. mustNotBeValid :: TxConstraints mustNotBeValid = singleton $ MustNotBeValid - --- | Are the constraints satisfiable given the time intervals? -isSatisfiable :: TxConstraints -> Boolean -isSatisfiable (TxConstraints { constraints }) = - let - intervals = - Array.mapMaybe - ( case _ of - MustValidateIn i -> Just i - _ -> Nothing - ) - constraints - itvl = foldl intersection always intervals - in - not (isEmpty itvl) - -pubKeyPayments - :: TxConstraints - -> Array (PaymentPubKeyHash /\ Value) -pubKeyPayments (TxConstraints { constraints }) = - toUnfoldable - $ fromFoldableWith (<>) - $ constraints >>= - case _ of - MustPayToPubKeyAddress pkh _ _ _ vl -> Array.singleton (pkh /\ vl) - _ -> [] - --- | The minimum `Value` that satisfies all `MustSpendAtLeast` constraints -mustSpendAtLeastTotal - :: TxConstraints -> Value -mustSpendAtLeastTotal = - foldr (join <<< f) mempty <<< _.constraints <<< unwrap - where - f :: TxConstraint -> Value - f (MustSpendAtLeast v) = v - f _ = mempty - --- | The minimum `Value` that satisfies all `MustProduceAtLeast` constraints -mustProduceAtLeastTotal - :: TxConstraints -> Value -mustProduceAtLeastTotal = - foldr (join <<< f) mempty <<< _.constraints <<< unwrap - where - f :: TxConstraint -> Value - f (MustProduceAtLeast v) = v - f _ = mempty - -requiredSignatories - :: TxConstraints - -> Array PaymentPubKeyHash -requiredSignatories = foldMap f <<< _.constraints <<< unwrap - where - f :: TxConstraint -> Array PaymentPubKeyHash - f (MustBeSignedBy pkh) = Array.singleton pkh - f _ = [] - -requiredMonetaryPolicies - :: TxConstraints - -> Array MintingPolicyHash -requiredMonetaryPolicies = foldMap f <<< _.constraints <<< unwrap - where - f :: TxConstraint -> Array MintingPolicyHash - f (MustMintValue mph _ _ _ _) = Array.singleton mph - f _ = [] - -requiredDatums - :: TxConstraints -> Array Datum -requiredDatums = foldMap f <<< _.constraints <<< unwrap - where - f :: TxConstraint -> Array Datum - f (MustIncludeDatum dt) = Array.singleton dt - f _ = [] diff --git a/src/Internal/Types/UsedTxOuts.purs b/src/Internal/Types/UsedTxOuts.purs index 6f8b807cd0..d18e864f81 100644 --- a/src/Internal/Types/UsedTxOuts.purs +++ b/src/Internal/Types/UsedTxOuts.purs @@ -18,6 +18,7 @@ module Ctl.Internal.Types.UsedTxOuts , withLockedTransactionInputs ) where +import Cardano.Types.Transaction (Transaction) import Cardano.Types.TransactionHash (TransactionHash) import Control.Alt ((<$>)) import Control.Alternative (guard, pure) @@ -27,7 +28,6 @@ import Control.Category ((<<<), (>>>)) import Control.Monad.Error.Class (class MonadError, catchError, throwError) import Control.Monad.RWS (ask) import Control.Monad.Reader (class MonadAsk) -import Ctl.Internal.Cardano.Types.Transaction (Transaction) import Data.Array (concatMap) import Data.Foldable (class Foldable, all, foldr) import Data.Function (($)) @@ -226,4 +226,4 @@ isTxOutRefUsed ref = do txOutRefs :: Transaction -> Set { transactionId :: TransactionHash, index :: UInt } -txOutRefs tx = Set.map unwrap (unwrap (unwrap tx).body).inputs +txOutRefs tx = Set.fromFoldable $ map unwrap (unwrap (unwrap tx).body).inputs diff --git a/src/Internal/Types/Validator.purs b/src/Internal/Types/Validator.purs new file mode 100644 index 0000000000..fcb935cc01 --- /dev/null +++ b/src/Internal/Types/Validator.purs @@ -0,0 +1,29 @@ +module Ctl.Internal.Types.Validator + ( Validator(Validator) + ) where + +import Prelude + +import Aeson (class DecodeAeson, class EncodeAeson, encodeAeson) +import Cardano.Types.PlutusScript (PlutusScript(PlutusScript)) +import Ctl.Internal.Helpers (decodeTaggedNewtype) +import Data.Generic.Rep (class Generic) +import Data.Newtype (class Newtype) +import Data.Show.Generic (genericShow) + +newtype Validator = Validator PlutusScript + +derive instance Generic Validator _ +derive instance Newtype Validator _ +derive newtype instance Eq Validator +derive newtype instance Ord Validator + +instance DecodeAeson Validator where + decodeAeson = decodeTaggedNewtype "getValidator" Validator + +instance EncodeAeson Validator where + encodeAeson (Validator script) = + encodeAeson { "getValidator": script } + +instance Show Validator where + show = genericShow diff --git a/src/Internal/Types/ValidatorHash.purs b/src/Internal/Types/ValidatorHash.purs new file mode 100644 index 0000000000..064edc361c --- /dev/null +++ b/src/Internal/Types/ValidatorHash.purs @@ -0,0 +1,31 @@ +module Ctl.Internal.Types.ValidatorHash + ( ValidatorHash(ValidatorHash) + ) where + +import Prelude + +import Aeson (class DecodeAeson, class EncodeAeson) +import Cardano.FromData (class FromData) +import Cardano.FromMetadata (class FromMetadata) +import Cardano.ToData (class ToData) +import Cardano.ToMetadata (class ToMetadata) +import Cardano.Types.ScriptHash (ScriptHash) +import Data.Generic.Rep (class Generic) +import Data.Newtype (class Newtype) +import Data.Show.Generic (genericShow) + +newtype ValidatorHash = ValidatorHash ScriptHash + +derive instance Generic ValidatorHash _ +derive instance Newtype ValidatorHash _ +derive newtype instance Eq ValidatorHash +derive newtype instance Ord ValidatorHash +derive newtype instance FromData ValidatorHash +derive newtype instance ToData ValidatorHash +derive newtype instance FromMetadata ValidatorHash +derive newtype instance ToMetadata ValidatorHash +derive newtype instance EncodeAeson ValidatorHash +derive newtype instance DecodeAeson ValidatorHash + +instance Show ValidatorHash where + show = genericShow diff --git a/src/Internal/Wallet.purs b/src/Internal/Wallet.purs index 30b7721ae6..608d6d5a0f 100644 --- a/src/Internal/Wallet.purs +++ b/src/Internal/Wallet.purs @@ -20,7 +20,6 @@ import Prelude import Cardano.Wallet.Cip30 as Cip30 import Control.Monad.Error.Class (catchError, throwError) -import Ctl.Internal.Types.Natural (fromInt', minus) import Ctl.Internal.Wallet.Cip30 (Cip30Wallet, mkCip30WalletAff) import Ctl.Internal.Wallet.Key ( KeyWallet @@ -73,7 +72,7 @@ mkWalletAff walletExtension = -- number of times, for Lode to become available. _mkLodeWalletAff :: Aff Wallet _mkLodeWalletAff = do - retryNWithIntervalUntil (fromInt' 10) (toNumber 100) + retryNWithIntervalUntil 10 (toNumber 100) $ liftEffect (isWalletAvailable LodeWallet) (GenericCip30 <$> (mkCip30WalletAff =<< Cip30.enable "LodeWallet" [])) `catchError` @@ -85,7 +84,7 @@ _mkLodeWalletAff = do if n == zero then pure unit else mBool >>= if _ then pure unit - else delay (wrap ms) *> retryNWithIntervalUntil (n `minus` one) ms mBool + else delay (wrap ms) *> retryNWithIntervalUntil (n - 1) ms mBool isWalletAvailable :: WalletExtension -> Effect Boolean isWalletAvailable = _isWalletAvailable <<< walletExtensionToName diff --git a/src/Plutus/PubKeyHash.purs b/src/Plutus/PubKeyHash.purs deleted file mode 100644 index 4eb8cbe707..0000000000 --- a/src/Plutus/PubKeyHash.purs +++ /dev/null @@ -1,41 +0,0 @@ -module Cardano.Plutus.Types.PubKeyHash where - -import Prelude - -import Aeson - ( class DecodeAeson - , class EncodeAeson - , decodeAeson - , encodeAeson - , (.:) - ) -import Ctl.Internal.FromData (class FromData) -import Ctl.Internal.Metadata.FromMetadata (class FromMetadata) -import Ctl.Internal.Metadata.ToMetadata (class ToMetadata) -import Ctl.Internal.Serialization.Hash (Ed25519KeyHash) -import Ctl.Internal.ToData (class ToData) -import Data.Generic.Rep (class Generic) -import Data.Newtype (class Newtype, unwrap, wrap) -import Data.Show.Generic (genericShow) - -newtype PubKeyHash = PubKeyHash Ed25519KeyHash - -derive instance Generic PubKeyHash _ -derive instance Newtype PubKeyHash _ -derive newtype instance Eq PubKeyHash -derive newtype instance FromData PubKeyHash -derive newtype instance FromMetadata PubKeyHash -derive newtype instance Ord PubKeyHash -derive newtype instance ToData PubKeyHash -derive newtype instance ToMetadata PubKeyHash - -instance Show PubKeyHash where - show = genericShow - -instance EncodeAeson PubKeyHash where - encodeAeson x = encodeAeson { getPubKeyHash: unwrap x } - -instance DecodeAeson PubKeyHash where - decodeAeson a = do - obj <- decodeAeson a - wrap <$> obj .: "getPubKeyHash"