diff --git a/flake.lock b/flake.lock index 44efaae..94c6f96 100644 --- a/flake.lock +++ b/flake.lock @@ -87,17 +87,17 @@ "cardano-base": { "flake": false, "locked": { - "lastModified": 1652788515, - "narHash": "sha256-l0KgomRi6YhEoOlFnBYEXhnZO2+PW68rhfUrbMXjhCQ=", + "lastModified": 1654537609, + "narHash": "sha256-4b0keLjRaVSdEwfBXB1iT3QPlsutdxSltGfBufT4Clw=", "owner": "input-output-hk", "repo": "cardano-base", - "rev": "631cb6cf1fa01ab346233b610a38b3b4cba6e6ab", + "rev": "0f3a867493059e650cda69e20a5cbf1ace289a57", "type": "github" }, "original": { "owner": "input-output-hk", "repo": "cardano-base", - "rev": "631cb6cf1fa01ab346233b610a38b3b4cba6e6ab", + "rev": "0f3a867493059e650cda69e20a5cbf1ace289a57", "type": "github" } }, @@ -121,34 +121,34 @@ "cardano-ledger": { "flake": false, "locked": { - "lastModified": 1657934159, - "narHash": "sha256-Pfc4FPSWySZLd/mqK1Gtru4IKfI/0HEdX4nSW2iOP0U=", + "lastModified": 1657127204, + "narHash": "sha256-4wcSA61TwoDTvJ6rx7tjEAJjQLO/cs8WGTHcOghNdTc=", "owner": "input-output-hk", "repo": "cardano-ledger", - "rev": "389b266d6226dedf3d2aec7af640b3ca4984c5ea", + "rev": "3be8a19083fc13d9261b1640e27dd389b51bb08e", "type": "github" }, "original": { "owner": "input-output-hk", "repo": "cardano-ledger", - "rev": "389b266d6226dedf3d2aec7af640b3ca4984c5ea", + "rev": "3be8a19083fc13d9261b1640e27dd389b51bb08e", "type": "github" } }, "cardano-prelude": { "flake": false, "locked": { - "lastModified": 1657171052, - "narHash": "sha256-T5hW85PfnuR6066jIhH/2g5dzTmI0JXsXSKwez8fXnw=", + "lastModified": 1617089317, + "narHash": "sha256-kgX3DKyfjBb8/XcDEd+/adlETsFlp5sCSurHWgsFAQI=", "owner": "input-output-hk", "repo": "cardano-prelude", - "rev": "533aec85c1ca05c7d171da44b89341fb736ecfe5", + "rev": "bb4ed71ba8e587f672d06edf9d2e376f4b055555", "type": "github" }, "original": { "owner": "input-output-hk", "repo": "cardano-prelude", - "rev": "533aec85c1ca05c7d171da44b89341fb736ecfe5", + "rev": "bb4ed71ba8e587f672d06edf9d2e376f4b055555", "type": "github" } }, @@ -549,17 +549,17 @@ "plutus": { "flake": false, "locked": { - "lastModified": 1657812223, - "narHash": "sha256-coD/Kpl7tutwXb6ukQCH5XojBjquYkW7ob0BWZtdpok=", + "lastModified": 1656585904, + "narHash": "sha256-ATwDR5LX2RN9YfoPhTxV7REvFoJnM4x/CN9XZVZlalg=", "owner": "input-output-hk", "repo": "plutus", - "rev": "8ab4c3355c5fdf67dcf6acc1f5a14668d5e6f0a9", + "rev": "69ab98c384703172f898eb5bcad1078ded521426", "type": "github" }, "original": { "owner": "input-output-hk", "repo": "plutus", - "rev": "8ab4c3355c5fdf67dcf6acc1f5a14668d5e6f0a9", + "rev": "69ab98c384703172f898eb5bcad1078ded521426", "type": "github" } }, diff --git a/flake.nix b/flake.nix index be8acb4..f1ccc97 100644 --- a/flake.nix +++ b/flake.nix @@ -11,13 +11,13 @@ haskell-nix-extra-hackage.inputs.haskell-nix.follows = "haskell-nix"; haskell-nix-extra-hackage.inputs.nixpkgs.follows = "nixpkgs"; - cardano-base.url = "github:input-output-hk/cardano-base/631cb6cf1fa01ab346233b610a38b3b4cba6e6ab"; + cardano-base.url = "github:input-output-hk/cardano-base/0f3a867493059e650cda69e20a5cbf1ace289a57"; cardano-base.flake = false; cardano-crypto.url = "github:input-output-hk/cardano-crypto/f73079303f663e028288f9f4a9e08bcca39a923e"; cardano-crypto.flake = false; - cardano-ledger.url = "github:input-output-hk/cardano-ledger/389b266d6226dedf3d2aec7af640b3ca4984c5ea"; + cardano-ledger.url = "github:input-output-hk/cardano-ledger/3be8a19083fc13d9261b1640e27dd389b51bb08e"; cardano-ledger.flake = false; - cardano-prelude.url = "github:input-output-hk/cardano-prelude/533aec85c1ca05c7d171da44b89341fb736ecfe5"; + cardano-prelude.url = "github:input-output-hk/cardano-prelude/bb4ed71ba8e587f672d06edf9d2e376f4b055555"; cardano-prelude.flake = false; flat.url = "github:Quid2/flat/ee59880f47ab835dbd73bea0847dab7869fc20d8"; flat.flake = false; @@ -25,7 +25,7 @@ goblins.flake = false; weigh.url = "github:fpco/weigh/bfcf4415144d7d2817dfcb91b6f9a6dfd7236de7"; weigh.flake = false; - plutus.url = "github:input-output-hk/plutus/8ab4c3355c5fdf67dcf6acc1f5a14668d5e6f0a9"; + plutus.url = "github:input-output-hk/plutus/69ab98c384703172f898eb5bcad1078ded521426"; plutus.flake = false; Win32-network.url = "github:input-output-hk/Win32-network/3825d3abf75f83f406c1f7161883c438dac7277d"; Win32-network.flake = false; diff --git a/src/Plutus/Model/Contract.hs b/src/Plutus/Model/Contract.hs index e76b3dd..e516ae6 100644 --- a/src/Plutus/Model/Contract.hs +++ b/src/Plutus/Model/Contract.hs @@ -48,6 +48,7 @@ module Plutus.Model.Contract ( payToKey, payToKeyDatum, payToScript, + payToScriptUntyped, loadRefScript, loadRefScriptDatum, payToRef, @@ -55,7 +56,9 @@ module Plutus.Model.Contract ( userSpend, spendPubKey, spendScript, + spendScriptUntyped, spendScriptRef, + spendScriptRefUntyped, spendBox, refInputInline, refInputHash, @@ -336,10 +339,10 @@ fromDatumMode = \case -- build Tx -- | Pay to public key with datum -payToKeyDatum :: ToData a => PubKeyHash -> DatumMode a -> Value -> Tx +payToKeyDatum :: (ToData a, HasAddress pubKeyHash) => pubKeyHash -> DatumMode a -> Value -> Tx payToKeyDatum pkh dat val = toExtra $ mempty - { P.txOutputs = [TxOut (pubKeyHashAddress pkh) val outDatum Nothing] + { P.txOutputs = [TxOut (toAddress pkh) val outDatum Nothing] , P.txData = datumMap } where @@ -365,6 +368,21 @@ payToScript script dat val = toExtra $ where (outDatum, datumMap) = fromDatumMode dat +-- | Pay to the script untyped. +-- The a type parameter represents the contents of the datum. +-- Example for datum: `()` and not `Datum $ toBuiltinDatum ()`. +payToScriptUntyped :: (ToData a, HasAddress script) => + script -> DatumMode a -> Value -> Tx +payToScriptUntyped script dat val = toExtra $ + mempty + { P.txOutputs = [TxOut (toAddress script) val outDatum Nothing] + , P.txData = datumMap + } + where + (outDatum, datumMap) = fromDatumMode dat + + + -- | Uploads the reference script to blockchain loadRefScript :: (IsValidator script) => script -> Value -> Tx loadRefScript script val = loadRefScriptBy script Nothing val @@ -426,6 +444,21 @@ spendScript tv ref red dat = toExtra $ { P.txInputs = S.singleton $ Fork.TxIn ref (Just $ Fork.ConsumeScriptAddress (Just $ Versioned (getLanguage tv) (toValidator tv)) (toRedeemer red) (toDatum dat)) } +-- | Spend script input untyped. +spendScriptUntyped :: + (HasValidator script, HasLanguage script) => + script -> + TxOutRef -> + Redeemer -> + Datum -> + Tx +spendScriptUntyped script ref red dat = toExtra $ + mempty + { P.txInputs = S.singleton $ Fork.TxIn ref (Just $ Fork.ConsumeScriptAddress (Just validator) red dat) + } + where + validator = Versioned (getLanguage script) ( toValidator script) + -- | Spends script that references other script spendScriptRef :: (IsValidator script) => @@ -445,6 +478,25 @@ spendScriptRef refScript script refOut red dat = toExtra $ sh = scriptHash script validator = toVersionedScript script +-- | Spends script that references other script untyped version +spendScriptRefUntyped :: + (HasValidator script, HasLanguage script) => + TxOutRef -> + script -> + TxOutRef -> + Redeemer -> + Datum -> + Tx +spendScriptRefUntyped refScript script refOut red dat = toExtra $ + mempty + { P.txInputs = S.singleton $ Fork.TxIn refOut (Just $ Fork.ConsumeScriptAddress Nothing red dat) + , P.txReferenceInputs = S.singleton $ Fork.TxIn refScript Nothing + , P.txScripts = M.singleton sh validator + } + where + sh = scriptHash script + validator = Versioned (getLanguage script) (getValidator $ toValidator script) + -- | Reference input with inlined datum refInputInline :: TxOutRef -> Tx refInputInline ref = toExtra $ @@ -564,25 +616,25 @@ txBoxValue :: TxBox a -> Value txBoxValue = txOutValue . txBoxOut -- | Read UTXOs with datums. -boxAt :: (IsValidator script) => script -> Run [TxBox script] +boxAt :: (HasAddress script, HasDatum script) => script -> Run [TxBox script] boxAt addr = do utxos <- utxoAt (toAddress addr) fmap catMaybes $ mapM (\(ref, tout) -> fmap (\dat -> TxBox ref tout dat) <$> datumAt ref) utxos -- | It expects that Typed validator can have only one UTXO -- which is NFT. -nftAt :: IsValidator script => script -> Run (TxBox script) +nftAt :: (HasAddress script, HasDatum script) => script -> Run (TxBox script) nftAt tv = head <$> boxAt tv -- | Safe query for single Box -withBox :: IsValidator script => (TxBox script -> Bool) -> script -> (TxBox script -> Run ()) -> Run () +withBox :: (HasAddress script, HasDatum script) => (TxBox script -> Bool) -> script -> (TxBox script -> Run ()) -> Run () withBox isBox script cont = withMayBy readMsg (L.find isBox <$> boxAt script) cont where readMsg = ("No UTxO box for: " <> ) <$> getPrettyAddress (toAddress script) -- | Reads single box from the list. we expect NFT to be a single UTXO for a given script. -withNft :: IsValidator script => script -> (TxBox script -> Run ()) -> Run () +withNft :: (HasAddress script, HasDatum script) => script -> (TxBox script -> Run ()) -> Run () withNft = withBox (const True) ---------------------------------------------------------------------- @@ -718,10 +770,11 @@ checkBalanceBy :: (a -> BalanceDiff) -> Run a -> Run a checkBalanceBy getDiffs act = do beforeSt <- get res <- act + afterSt <- get let BalanceDiff diffs = getDiffs res addrs = M.keys diffs before = fmap (`valueAtState` beforeSt) addrs - after <- mapM valueAt addrs + after = fmap (`valueAtState` afterSt) addrs mapM_ (logError . show . vcat <=< mapM ppError) (check addrs diffs before after) pure res where diff --git a/src/Plutus/Model/Fork/Cardano/Common.hs b/src/Plutus/Model/Fork/Cardano/Common.hs index fecfd49..6b12353 100644 --- a/src/Plutus/Model/Fork/Cardano/Common.hs +++ b/src/Plutus/Model/Fork/Cardano/Common.hs @@ -65,7 +65,7 @@ import Cardano.Ledger.Shelley.API.Types qualified as Shelley (Hash) import Cardano.Ledger.TxIn qualified as C import Cardano.Ledger.ShelleyMA.Timelocks qualified as C import Cardano.Ledger.Keys qualified as C -import Cardano.Ledger.Keys.WitVKey +import Cardano.Ledger.Shelley.TxBody (Delegation (Delegation), WitVKey) import Cardano.Ledger.Shelley.UTxO qualified as C import qualified Cardano.Crypto.Hash.Class as Crypto import Cardano.Ledger.Mary.Value qualified as C @@ -170,7 +170,7 @@ toDCert :: Network -> C.Coin -> C.Coin -> P.DCert -> Either ToCardanoError (C.DC toDCert network poolDeposit minPoolCost = \case P.DCertDelegRegKey (P.StakingHash stakingCredential) -> C.DCertDeleg . C.RegKey <$> toCredential stakingCredential P.DCertDelegDeRegKey (P.StakingHash stakingCredential) -> C.DCertDeleg . C.DeRegKey <$> toCredential stakingCredential - P.DCertDelegDelegate (P.StakingHash stakingCredential) pubKeyHash -> C.DCertDeleg . C.Delegate <$> (C.Delegation <$> toCredential stakingCredential <*> toPubKeyHash pubKeyHash) + P.DCertDelegDelegate (P.StakingHash stakingCredential) pubKeyHash -> C.DCertDeleg . C.Delegate <$> (Delegation <$> toCredential stakingCredential <*> toPubKeyHash pubKeyHash) P.DCertPoolRegister poolKeyHash poolVfr -> C.DCertPool . C.RegPool <$> toPoolParams poolKeyHash poolVfr P.DCertPoolRetire pkh n -> C.DCertPool . (\key -> C.RetirePool key (C.EpochNo (fromIntegral n)) ) <$> toPubKeyHash pkh P.DCertGenesis -> Left "DCertGenesis is not supported" diff --git a/src/Plutus/Model/Validator.hs b/src/Plutus/Model/Validator.hs index 8498632..b428622 100644 --- a/src/Plutus/Model/Validator.hs +++ b/src/Plutus/Model/Validator.hs @@ -12,6 +12,8 @@ module Plutus.Model.Validator( IsValidatorHash, TypedValidator(..), + UntypedValidator(..), + UntypedValidatorHash(..), TypedValidatorHash(..), TypedPolicy(..), TypedStake(..), @@ -99,6 +101,32 @@ instance HasValidator (TypedValidator datum redeemer) where instance HasAddress (TypedValidator datum redeemer) where toAddress = toAddress . toValidatorHash +--------------------------------------------------------------------- +-- untyped validator + +newtype UntypedValidator = + UntypedValidator { unUntypedValidator :: Versioned Validator } + deriving newtype (HasLanguage) + +instance HasValidator UntypedValidator where + toValidator (UntypedValidator (Versioned _lang validator)) = validator + +instance HasAddress UntypedValidator where + toAddress = toAddress . toValidatorHash + +--------------------------------------------------------------------- +-- untyped validator hash + +newtype UntypedValidatorHash = + UntypedValidatorHash { unTypedValidatorHash :: Versioned ValidatorHash } + deriving newtype (HasLanguage) + +instance HasValidatorHash UntypedValidatorHash where + toValidatorHash (UntypedValidatorHash (Versioned _lang vh)) = vh + +instance HasAddress UntypedValidatorHash where + toAddress (UntypedValidatorHash (Versioned _lang vh)) = toAddress vh + --------------------------------------------------------------------- -- typed validator hash diff --git a/src/Plutus/Model/Validator/V2.hs b/src/Plutus/Model/Validator/V2.hs index 843f1da..7dd3040 100644 --- a/src/Plutus/Model/Validator/V2.hs +++ b/src/Plutus/Model/Validator/V2.hs @@ -1,7 +1,10 @@ -- | Creation of typed validators for Plutus V2 module Plutus.Model.Validator.V2( mkTypedValidator, + mkTypedValidator', + mkUntypedValidator, mkTypedPolicy, + mkTypedPolicy', mkTypedStake, toBuiltinValidator, toBuiltinPolicy, @@ -13,13 +16,23 @@ import PlutusTx.Prelude qualified as Plutus import Plutus.V2.Ledger.Api import PlutusTx.Code (CompiledCode) -import Plutus.Model.Validator (TypedValidator(..), TypedPolicy(..), TypedStake(..)) +import Plutus.Model.Validator (TypedValidator(..), TypedPolicy(..), TypedStake(..), UntypedValidator (UntypedValidator)) import Plutus.Model.Fork.Ledger.Scripts (toV2) +mkTypedValidator' :: Validator -> TypedValidator datum redeemer +mkTypedValidator' = TypedValidator . toV2 + -- | Create Plutus V2 typed validator mkTypedValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) -> TypedValidator datum redeemer mkTypedValidator = TypedValidator . toV2 . mkValidatorScript +-- | Create Plutus V2 untyped validator +mkUntypedValidator :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) -> UntypedValidator +mkUntypedValidator = UntypedValidator . toV2 . mkValidatorScript + +mkTypedPolicy' :: MintingPolicy -> TypedPolicy redeemer +mkTypedPolicy' = TypedPolicy . toV2 + -- | Create Plutus V2 typed minting policy mkTypedPolicy :: CompiledCode (BuiltinData -> BuiltinData -> ()) -> TypedPolicy redeemer mkTypedPolicy = TypedPolicy . toV2 . mkMintingPolicyScript