Merge branch '400-ogmios' of github.com:geniusyield/atlas into 400-og…

…mios
geniusyield · Feb 8, 2025 · f9af119 · f9af119
2 parents ccad75d + 728d5ef
commit f9af119
Show file tree

Hide file tree

Showing 12 changed files with 204 additions and 16 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
+<https://github.com/geniusyield/atlas/issues/399#issuecomment-2618617724>
+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
@@ -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
@@ -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)