diff --git a/CHANGELOG.md b/CHANGELOG.md index 02a99833..28fb078f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,13 @@ -## 0.10.1 +## 0.11.1 * Adds support of Ogmios-Kupo provider, see section on providers at https://atlas-app.io/getting-started/endpoints. * `ToJSON` instance for `GYTxOutRefCbor`. * New `GeniusYield.Debug` module to perform Atlas's operation from repl. +## 0.11.0 + +* Allows reference scripts to be of version greater than the minimum supported constrained version of `GYTxSkeleton`. Thanks [@SeungheonOh](https://github.com/SeungheonOh) for finding [this bug](https://github.com/geniusyield/atlas/issues/404)! Please visit the linked issue for more details. + ## 0.10.0 * Support of extended keys in `runGYTxMonadIO`. diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index 182bbf4e..ab2f0ecf 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: atlas-cardano -version: 0.10.1 +version: 0.11.1 synopsis: Application backend for Plutus smart contracts on Cardano description: Atlas is an all-in-one, Haskell-native application backend for writing off-chain code for on-chain Plutus smart contracts. @@ -323,6 +323,7 @@ test-suite atlas-tests GeniusYield.Test.FeeTracking GeniusYield.Test.GYTxBody GeniusYield.Test.GYTxSkeleton + GeniusYield.Test.GYTxOutRefCbor GeniusYield.Test.OnChain.AlwaysSucceeds GeniusYield.Test.OnChain.AlwaysSucceeds.Compiled GeniusYield.Test.OnChain.GuessRefInputDatum diff --git a/src/GeniusYield/Examples/Gift.hs b/src/GeniusYield/Examples/Gift.hs index 8e6d20c3..8a95fcd6 100644 --- a/src/GeniusYield/Examples/Gift.hs +++ b/src/GeniusYield/Examples/Gift.hs @@ -10,11 +10,13 @@ module GeniusYield.Examples.Gift ( -- * Scripts giftValidatorV1, giftValidatorV2, + giftValidatorV3, ) where import GeniusYield.Types import GeniusYield.Examples.Common (toDeBruijn) +import PlutusCore.MkPlc qualified as UPLC import PlutusCore.Version qualified as PLC import PlutusLedgerApi.Common qualified as Plutus import UntypedPlutusCore qualified as UPLC @@ -37,16 +39,37 @@ giftScript = redeemerName = UPLC.Name "redeemer" (UPLC.Unique 1) scName = UPLC.Name "sc" (UPLC.Unique 2) +-- | A very simple script: @\sc -> ()@ +giftScriptV3 :: UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () +giftScriptV3 = + UPLC.LamAbs ann scName $ + UPLC.mkConstant ann () + where + ann = () + + scName = UPLC.Name "sc" (UPLC.Unique 0) + giftScript' :: UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () giftScript' = toDeBruijn giftScript +giftScriptV3' :: UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () +giftScriptV3' = toDeBruijn giftScriptV3 + giftValidatorV1 :: GYScript 'PlutusV1 giftValidatorV1 = validatorFromSerialisedScript giftValidatorPlutusSerialised giftValidatorV2 :: GYScript 'PlutusV2 giftValidatorV2 = validatorFromSerialisedScript giftValidatorPlutusSerialised +giftValidatorV3 :: GYScript 'PlutusV3 +giftValidatorV3 = validatorFromSerialisedScript giftValidatorPlutusV3Serialised + giftValidatorPlutusSerialised :: Plutus.SerialisedScript giftValidatorPlutusSerialised = Plutus.serialiseUPLC $ UPLC.Program () PLC.plcVersion100 giftScript' + +giftValidatorPlutusV3Serialised :: Plutus.SerialisedScript +giftValidatorPlutusV3Serialised = + Plutus.serialiseUPLC $ + UPLC.Program () PLC.plcVersion110 giftScriptV3' diff --git a/src/GeniusYield/Test/Privnet/Examples/Common.hs b/src/GeniusYield/Test/Privnet/Examples/Common.hs index 694cb920..b44e2e35 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Common.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Common.hs @@ -5,5 +5,5 @@ import GeniusYield.Test.Utils import GeniusYield.TxBuilder import GeniusYield.Types -addRefScriptToLimbo :: GYScript PlutusV2 -> GYTxMonadIO GYTxOutRef +addRefScriptToLimbo :: forall v. v `VersionIsGreaterOrEqual` 'PlutusV2 => GYScript v -> GYTxMonadIO GYTxOutRef addRefScriptToLimbo sc = scriptAddress limboValidatorV2 >>= flip addRefScript sc diff --git a/src/GeniusYield/Test/Privnet/Examples/Gift.hs b/src/GeniusYield/Test/Privnet/Examples/Gift.hs index 7b262d67..53d05764 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Gift.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Gift.hs @@ -323,7 +323,7 @@ tests setup = -- NOTE: TxValidationErrorInMode (ShelleyTxValidationError ShelleyBasedEraBabbage (ApplyTxError [UtxowFailure (FromAlonzoUtxowFail (WrappedShelleyEraFailure (ExtraneousScriptWitnessesUTXOW -- Apparently we MUST NOT include the script if there is a utxo input with that script. Even if we consume that utxo. ctxRun ctx (ctxUser2 ctx) $ do - grabGiftsTx' <- grabGiftsRef ref giftValidatorV2 >>= traverse buildTxBody + grabGiftsTx' <- grabGiftsRef @_ @'PlutusV2 ref giftValidatorV2 >>= traverse buildTxBody mapM_ signAndSubmitConfirmed grabGiftsTx' -- Check final balance @@ -435,8 +435,43 @@ tests setup = sV1 <- grabGifts giftValidatorV1 return (liftA2 (<>) sV2 sV1) -} + testCaseSteps "refscript_mixup_v2_v3" $ \info -> withSetup info setup $ \ctx -> do + -- in this test we consume both plutus v2 and v3 reference scripts in a single transaction. + -- + let ironAC = ctxIron ctx + + refV2 <- ctxRun ctx (ctxUserF ctx) . addRefScriptToLimbo $ validatorToScript giftValidatorV2 + refV3 <- ctxRun ctx (ctxUserF ctx) . addRefScriptToLimbo $ validatorToScript giftValidatorV3 + + info $ "Reference (V2) at " ++ show refV2 + info $ "Reference (V3) at " ++ show refV3 + + -- put some V2 gifts + ctxRun ctx (ctxUserF ctx) $ do + addr <- scriptAddress giftValidatorV2 + txBodyPlaceV2 <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) - testCaseSteps "inline datums V1+V2" $ \info -> withSetup info setup $ \ctx -> do + signAndSubmitConfirmed_ txBodyPlaceV2 + + info "Put V2 gifts" + + -- put some V3 gifts + ctxRun ctx (ctxUserF ctx) $ do + addr <- scriptAddress giftValidatorV3 + txBodyPlaceV3 <- buildTxBody $ mustHaveOutput $ mkGYTxOut addr (valueSingleton ironAC 10) (datumFromPlutusData ()) + + signAndSubmitConfirmed_ txBodyPlaceV3 + + info "Put V3 gifts" + grabTxBody <- ctxRun ctx (ctxUserF ctx) $ do + v2Gifts <- grabGiftsRef refV2 giftValidatorV2 + v3Gifts <- grabGiftsRef refV3 giftValidatorV3 + let gifts :: Maybe (GYTxSkeleton 'PlutusV2) = liftA2 (<>) v2Gifts v3Gifts + grabGiftsTx' <- traverse buildTxBody gifts + mapM_ signAndSubmitConfirmed grabGiftsTx' + pure grabGiftsTx' + info $ "Grabbed gifts tx body: " ++ show grabTxBody + , testCaseSteps "inline datums V1+V2" $ \info -> withSetup info setup $ \ctx -> do -- in this test we consume UTxO with Plutus V1 script -- and in the same transaction create an output where we force inline datum usage -- @@ -618,10 +653,11 @@ grabGifts validator = do -- | Grab gifts using a referenced validator. grabGiftsRef :: - GYTxQueryMonad m => + forall m u v. + (GYTxQueryMonad m, v `VersionIsGreaterOrEqual` u, u `VersionIsGreaterOrEqual` 'PlutusV2, v `VersionIsGreaterOrEqual` 'PlutusV2) => GYTxOutRef -> - GYScript 'PlutusV2 -> - m (Maybe (GYTxSkeleton 'PlutusV2)) + GYScript v -> + m (Maybe (GYTxSkeleton u)) grabGiftsRef ref validator = do addr <- scriptAddress validator utxo <- utxosAtAddress addr Nothing diff --git a/src/GeniusYield/Test/Privnet/Examples/Misc.hs b/src/GeniusYield/Test/Privnet/Examples/Misc.hs index 07deb9d0..b5c96d3d 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Misc.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Misc.hs @@ -40,7 +40,7 @@ tests setup = ctxRun ctx (ctxUser2 ctx) $ do txBodyMint <- - buildTxBody $ + buildTxBody @'PlutusV2 $ mustHaveInput (GYTxIn utxoAsParam GYTxInWitnessKey) <> mustMint (GYBuildPlutusScript $ GYBuildPlutusScriptReference refScript policyAsScript) unitRedeemer tn amt signAndSubmitConfirmed_ txBodyMint diff --git a/src/GeniusYield/Types/BuildScript.hs b/src/GeniusYield/Types/BuildScript.hs index beda9514..cc47a90f 100644 --- a/src/GeniusYield/Types/BuildScript.hs +++ b/src/GeniusYield/Types/BuildScript.hs @@ -56,18 +56,20 @@ deriving instance Ord (GYBuildScript v) data GYBuildPlutusScript (u :: PlutusVersion) where -- | 'VersionIsGreaterOrEqual' restricts which version validators can be used in this transaction. GYBuildPlutusScriptInlined :: forall u v. v `VersionIsGreaterOrEqual` u => GYScript v -> GYBuildPlutusScript u - -- | Reference inputs can be only used in V2 transactions. - GYBuildPlutusScriptReference :: forall v. v `VersionIsGreaterOrEqual` 'PlutusV2 => !GYTxOutRef -> !(GYScript v) -> GYBuildPlutusScript v + -- | Reference inputs can be only used in V2 & beyond transactions. + -- + -- Constraint @v `VersionIsGreaterOrEqual` 'PlutusV2@ is redundant but is there to guide GHC as it doesn't know that @v >= u@ and @u >= 'PlutusV2@ imply that @v >= 'PlutusV2@. + GYBuildPlutusScriptReference :: forall u v. (v `VersionIsGreaterOrEqual` u, u `VersionIsGreaterOrEqual` 'PlutusV2, v `VersionIsGreaterOrEqual` 'PlutusV2) => !GYTxOutRef -> !(GYScript v) -> GYBuildPlutusScript u deriving instance Show (GYBuildPlutusScript v) instance Eq (GYBuildPlutusScript v) where - GYBuildPlutusScriptReference ref1 script1 == GYBuildPlutusScriptReference ref2 script2 = ref1 == ref2 && script1 == script2 + GYBuildPlutusScriptReference ref1 script1 == GYBuildPlutusScriptReference ref2 script2 = ref1 == ref2 && eqScript script1 script2 GYBuildPlutusScriptInlined v1 == GYBuildPlutusScriptInlined v2 = defaultEq v1 v2 _ == _ = False instance Ord (GYBuildPlutusScript v) where - GYBuildPlutusScriptReference r s `compare` GYBuildPlutusScriptReference r' s' = compare r r' <> compare s s' + GYBuildPlutusScriptReference r s `compare` GYBuildPlutusScriptReference r' s' = compare r r' <> compareScript s s' GYBuildPlutusScriptReference _ _ `compare` _ = LT GYBuildPlutusScriptInlined p `compare` GYBuildPlutusScriptInlined p' = defaultCompare p p' GYBuildPlutusScriptInlined _ `compare` _ = GT @@ -111,7 +113,7 @@ type GYStakeValScript v = GYBuildPlutusScript v pattern GYStakeValScript :: () => VersionIsGreaterOrEqual v u => GYScript v -> GYBuildPlutusScript u pattern GYStakeValScript s = GYBuildPlutusScriptInlined s -pattern GYStakeValReference :: () => VersionIsGreaterOrEqual u PlutusV2 => GYTxOutRef -> GYScript u -> GYBuildPlutusScript u +pattern GYStakeValReference :: () => (v `VersionIsGreaterOrEqual` u, u `VersionIsGreaterOrEqual` PlutusV2, v `VersionIsGreaterOrEqual` PlutusV2) => GYTxOutRef -> GYScript v -> GYBuildPlutusScript u pattern GYStakeValReference r s = GYBuildPlutusScriptReference r s {-# COMPLETE GYStakeValScript, GYStakeValReference #-} @@ -141,7 +143,7 @@ type GYMintScript v = GYBuildScript v pattern GYMintScript :: () => VersionIsGreaterOrEqual v u => GYScript v -> GYBuildScript u pattern GYMintScript s = GYBuildPlutusScript (GYBuildPlutusScriptInlined s) -pattern GYMintReference :: () => VersionIsGreaterOrEqual u PlutusV2 => GYTxOutRef -> GYScript u -> GYBuildScript u +pattern GYMintReference :: () => (v `VersionIsGreaterOrEqual` u, u `VersionIsGreaterOrEqual` PlutusV2, v `VersionIsGreaterOrEqual` PlutusV2) => GYTxOutRef -> GYScript v -> GYBuildScript u pattern GYMintReference r s = GYBuildPlutusScript (GYBuildPlutusScriptReference r s) gyMintingScriptWitnessToApiPlutusSW :: diff --git a/src/GeniusYield/Types/Script.hs b/src/GeniusYield/Types/Script.hs index e7c415d7..353959b9 100644 --- a/src/GeniusYield/Types/Script.hs +++ b/src/GeniusYield/Types/Script.hs @@ -98,9 +98,12 @@ module GeniusYield.Types.Script ( -- * Script GYScript, + eqScript, + compareScript, scriptHash, hashScript, scriptVersion, + scriptVersion', validatorToScript, mintingPolicyToScript, stakeValidatorToScript, @@ -445,6 +448,14 @@ data GYScript (v :: PlutusVersion) !(Api.PlutusScript (PlutusVersionToApi v)) !Api.ScriptHash +-- | Heterogeneous script equality. Preferably use `Eq` instance when possible. +eqScript :: GYScript u -> GYScript v -> Bool +eqScript s1 s2 = scriptVersion' s1 == scriptVersion' s2 && scriptHash s1 == scriptHash s2 + +-- | Heterogeneous script comparison. Preferably use `Ord` instance when possible. +compareScript :: GYScript u -> GYScript v -> Ordering +compareScript s1 s2 = compare (scriptVersion' s1) (scriptVersion' s2) <> compare (scriptHash s1) (scriptHash s2) + {- | Equality and comparison are on script hash. As hash is cryptographicly strong, and 'GYScript' constructor is not @@ -504,6 +515,9 @@ scriptToSerialisedScript script = scriptVersion :: GYScript v -> SingPlutusVersion v scriptVersion (GYScript v _ _) = v +scriptVersion' :: GYScript v -> PlutusVersion +scriptVersion' s = scriptVersion s & fromSingPlutusVersion + scriptToApi :: GYScript v -> Api.PlutusScript (PlutusVersionToApi v) scriptToApi (GYScript _ api _) = api diff --git a/src/GeniusYield/Types/TxIn.hs b/src/GeniusYield/Types/TxIn.hs index 07bdc77d..559587b1 100644 --- a/src/GeniusYield/Types/TxIn.hs +++ b/src/GeniusYield/Types/TxIn.hs @@ -57,7 +57,7 @@ type GYInScript = GYBuildPlutusScript pattern GYInScript :: () => v `VersionIsGreaterOrEqual` u => GYScript v -> GYBuildPlutusScript u pattern GYInScript s = GYBuildPlutusScriptInlined s -pattern GYInReference :: () => VersionIsGreaterOrEqual u PlutusV2 => GYTxOutRef -> GYScript u -> GYBuildPlutusScript u +pattern GYInReference :: () => (v `VersionIsGreaterOrEqual` u, u `VersionIsGreaterOrEqual` PlutusV2, v `VersionIsGreaterOrEqual` PlutusV2) => GYTxOutRef -> GYScript v -> GYBuildPlutusScript u pattern GYInReference ref s = GYBuildPlutusScriptReference ref s {-# COMPLETE GYInScript, GYInReference #-} diff --git a/src/GeniusYield/Types/TxOutRef.hs b/src/GeniusYield/Types/TxOutRef.hs index 19d98420..8e066490 100644 --- a/src/GeniusYield/Types/TxOutRef.hs +++ b/src/GeniusYield/Types/TxOutRef.hs @@ -27,6 +27,7 @@ module GeniusYield.Types.TxOutRef ( import Cardano.Api qualified as Api import Codec.CBOR.Read qualified as CBOR import Codec.CBOR.Term qualified as CBOR +import Codec.CBOR.Write qualified as CBOR import Control.Lens ((?~)) import Data.Aeson qualified as Aeson import Data.Attoparsec.ByteString.Char8 qualified as Atto @@ -255,6 +256,35 @@ instance Aeson.FromJSON GYTxOutRefCbor where Left err -> fail $ T.unpack err Right ref -> return ref +{- | Warning: this JSON instance does not satisfy +@JSON --> 'GYTxOutRefCbor' --> JSON === id@ since some information in the hex +encoded CBOR string is lost when going from @'GYTxOutRefCbor'@ to @JSON@. + +In practise, this shouldn't be an issue -- see + +for details. +-} +instance Aeson.ToJSON GYTxOutRefCbor where + toJSON (GYTxOutRefCbor gyTxOutRef) = + let Api.TxIn txId (Api.TxIx txIx) = GeniusYield.Types.TxOutRef.txOutRefToApi gyTxOutRef + -- NOTE(jaredponn) January 27, 2025: the + -- value of this int doesn't matter when it is decoded + -- with the 'Aeson.FromJSON' instance, so we may pick + -- any value -- in particular, we choose 0. + someInt = 0 + in Aeson.String $ + TE.decodeASCII $ + Base16.encode $ + CBOR.toStrictByteString $ + CBOR.encodeTerm $ + CBOR.TList + [ CBOR.TList + [ CBOR.TBytes $ Api.serialiseToRawBytes txId + , CBOR.TInt $ fromIntegral txIx + ] + , CBOR.TInt someInt + ] + ------------------------------------------------------------------------------- -- swagger schema ------------------------------------------------------------------------------- diff --git a/tests/GeniusYield/Test/GYTxOutRefCbor.hs b/tests/GeniusYield/Test/GYTxOutRefCbor.hs new file mode 100644 index 00000000..dadb9be5 --- /dev/null +++ b/tests/GeniusYield/Test/GYTxOutRefCbor.hs @@ -0,0 +1,76 @@ +module GeniusYield.Test.GYTxOutRefCbor ( + gyTxOutRefCborTests, +) where + +import Control.Monad (replicateM) +import Data.Maybe (fromJust) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Gen, arbitrary, counterexample, elements, forAllShrink, property, shrink, testProperty, (===)) + +import Data.Aeson (eitherDecode', encode) + +import GeniusYield.Types ( + GYTxOutRef, + GYTxOutRefCbor (GYTxOutRefCbor, getTxOutRefHex), + txIdFromHex, + txOutRefFromTuple, + txOutRefToTuple, + ) + +-- | Test group for the 'GYTxOutRefCbor' type +gyTxOutRefCborTests :: TestTree +gyTxOutRefCborTests = testGroup "GYTxOutRefCbor" basicTests + +basicTests :: [TestTree] +basicTests = + [ testProperty "Roundtrip GYTxOutRefCbor --> JSON --> GYTxOutRefCbor === id" $ + forAllShrink genGyTxOutRefCbor shrinkGyTxOutRefCbor $ \gyTxOutRefCbor -> + let encodedGyTxOutRefCbor = encode gyTxOutRefCbor + in counterexample ("JSON encoded GYTxOutRefCbor " ++ show encodedGyTxOutRefCbor) $ + case eitherDecode' (encode gyTxOutRefCbor) of + Right decodedGyTxOutRefCbor -> + counterexample + ("JSON decoded of the encoded GYTxOutRefCbor " ++ show decodedGyTxOutRefCbor) + $ + -- NOTE(jaredponn) January 31, 2025: it's a bit + -- weird that 'GYTxOutRefCbor' doesn't have an + -- 'Eq' instance, so we unwrap it and use the + -- underlying 'GYTxOutRef' 'Eq' instance. + getTxOutRefHex gyTxOutRefCbor === getTxOutRefHex decodedGyTxOutRefCbor + Left _err -> property False + ] + +-- | Generator for 'GYTxOutRefCbor' +genGyTxOutRefCbor :: Gen GYTxOutRefCbor +genGyTxOutRefCbor = GYTxOutRefCbor <$> genGyTxOutRef + +-- | Generator for 'GYTxOutRef' +genGyTxOutRef :: Gen GYTxOutRef +genGyTxOutRef = do + txId <- fmap + ( fromJust + -- NOTE(jaredponn) January 31, 2025: this 'fromJust' is safe -- we + -- know that TxIds are 32 bytes long, and we generate the strings + -- s.t. they are always 32 bytes long + . txIdFromHex + . concat + ) + $ replicateM 32 + $ do + firstHexDigit <- elements $ ['0' .. '9'] ++ ['a' .. 'f'] + secondHexDigit <- elements $ ['0' .. '9'] ++ ['a' .. 'f'] + return [firstHexDigit, secondHexDigit] + txIx <- arbitrary + + return $ txOutRefFromTuple (txId, txIx) + +-- | Shrinks 'GYTxOutRefCbor' using the underlying 'shrinkGyTxOutRef' +shrinkGyTxOutRefCbor :: GYTxOutRefCbor -> [GYTxOutRefCbor] +shrinkGyTxOutRefCbor (GYTxOutRefCbor gyTxOutRef) = + map GYTxOutRefCbor $ shrinkGyTxOutRef gyTxOutRef + +-- | Shrinks 'GYTxOutRef'. This only shrinks the transaction index. +shrinkGyTxOutRef :: GYTxOutRef -> [GYTxOutRef] +shrinkGyTxOutRef gyTxOutRef = + let (txId, txIx) = txOutRefToTuple gyTxOutRef + in map (\shrunkTxIx -> txOutRefFromTuple (txId, shrunkTxIx)) $ shrink txIx diff --git a/tests/atlas-tests.hs b/tests/atlas-tests.hs index ec2fa748..7474d647 100644 --- a/tests/atlas-tests.hs +++ b/tests/atlas-tests.hs @@ -24,6 +24,7 @@ import GeniusYield.Test.CoinSelection (coinSelectionTests) import GeniusYield.Test.Config (configTests) import GeniusYield.Test.FeeTracking (feeTrackingTests) import GeniusYield.Test.GYTxBody (gyTxBodyTests) +import GeniusYield.Test.GYTxOutRefCbor (gyTxOutRefCborTests) import GeniusYield.Test.GYTxSkeleton (gyTxSkeletonTests) import GeniusYield.Test.Providers (providersTests) import GeniusYield.Test.RefInput (refInputTests) @@ -79,6 +80,7 @@ main = do , gyTxBodyTests , configTests , gyTxSkeletonTests + , gyTxOutRefCborTests , refInputTests , feeTrackingTests , stakeTests (head configs)