From a0810babc4ec1655f37dc37bd0fdad9472c5300f Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Fri, 12 Jul 2024 13:30:48 -0600 Subject: [PATCH 01/15] Move Clb module into tests and remove redundant `Address` module --- atlas-cardano.cabal | 3 +- src/GeniusYield/Test/Address.hs | 72 ---------------------- src/GeniusYield/{TxBuilder => Test}/Clb.hs | 8 +-- src/GeniusYield/Test/Utils.hs | 16 ++--- tests/GeniusYield/Test/RefInput.hs | 2 +- 5 files changed, 10 insertions(+), 91 deletions(-) delete mode 100644 src/GeniusYield/Test/Address.hs rename src/GeniusYield/{TxBuilder => Test}/Clb.hs (99%) diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index d6d47d1e..8e7d89d1 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -84,7 +84,7 @@ library GeniusYield.ReadJSON GeniusYield.Scripts.TestToken GeniusYield.Swagger.Utils - GeniusYield.Test.Address + GeniusYield.Test.Clb GeniusYield.Test.FakeCoin GeniusYield.Test.Privnet.Asserts GeniusYield.Test.Privnet.Ctx @@ -103,7 +103,6 @@ library GeniusYield.Transaction.Common GeniusYield.TxBuilder GeniusYield.TxBuilder.Class - GeniusYield.TxBuilder.Clb GeniusYield.TxBuilder.Common GeniusYield.TxBuilder.Errors GeniusYield.TxBuilder.IO diff --git a/src/GeniusYield/Test/Address.hs b/src/GeniusYield/Test/Address.hs deleted file mode 100644 index ef53b807..00000000 --- a/src/GeniusYield/Test/Address.hs +++ /dev/null @@ -1,72 +0,0 @@ --- | Classes to get addresses and work with addresses -module GeniusYield.Test.Address ( - HasAddress (..), - HasStakingCredential (..), - AppendStaking (..), - -- appendStakingCredential, - appendCredential, - appendStakingPubKey, - -- appendStakingScript, -) where - --- import Cardano.Simple.PlutusLedgerApi.V1.Scripts --- import Cardano.Simple.TxExtra (keyToStaking) -import PlutusLedgerApi.V1.Address -import PlutusLedgerApi.V2 -import Prelude - --- | Everything that has address -class HasAddress a where - toAddress :: a -> Address - -instance HasAddress Address where - toAddress = id - -instance HasAddress PubKeyHash where - toAddress = pubKeyHashAddress - --- instance HasAddress ScriptHash where --- toAddress = scriptHashAddress - --- | Everything that has staking credential -class HasStakingCredential a where - toStakingCredential :: a -> StakingCredential - -instance HasStakingCredential StakingCredential where - toStakingCredential = id - --- instance HasStakingCredential PubKeyHash where --- toStakingCredential = keyToStaking - --- | Encodes appening of staking address -data AppendStaking a - = AppendStaking StakingCredential a - -instance HasAddress a => HasAddress (AppendStaking a) where - toAddress (AppendStaking stakeCred a) = appendStake (toAddress a) - where - appendStake addr = addr {addressStakingCredential = Just stakeCred} - --- -- | Appends staking credential to a script --- appendStakingCredential :: StakingCredential -> script -> AppendStaking script --- appendStakingCredential sCred script = --- case sCred of --- StakingHash cred -> --- case cred of --- PubKeyCredential pkh -> --- appendStakingPubKey pkh script --- ScriptCredential (ScriptHash hash) -> --- appendStakingScript (StakeValidatorHash hash) script --- StakingPtr {} -> error "StakingPtr is not supported" - --- | Append staking credential info -appendCredential :: Credential -> a -> AppendStaking a -appendCredential cred = AppendStaking (StakingHash cred) - --- | Append staking public key info -appendStakingPubKey :: PubKeyHash -> a -> AppendStaking a -appendStakingPubKey pkh = appendCredential (PubKeyCredential pkh) - --- -- | Append staking script info --- appendStakingScript :: StakeValidatorHash -> a -> AppendStaking a --- appendStakingScript sh = appendCredential (ScriptCredential $ coerce sh) diff --git a/src/GeniusYield/TxBuilder/Clb.hs b/src/GeniusYield/Test/Clb.hs similarity index 99% rename from src/GeniusYield/TxBuilder/Clb.hs rename to src/GeniusYield/Test/Clb.hs index 39489f66..2e8d79be 100644 --- a/src/GeniusYield/TxBuilder/Clb.hs +++ b/src/GeniusYield/Test/Clb.hs @@ -1,14 +1,14 @@ {-# LANGUAGE LambdaCase #-} {-| -Module : GeniusYield.TxBuilder.Clb +Module : GeniusYield.Test.Clb Copyright : (c) 2023 GYELD GMBH License : Apache 2.0 Maintainer : support@geniusyield.co Stability : develop -} -module GeniusYield.TxBuilder.Clb +module GeniusYield.Test.Clb ( Wallet (..) , WalletName , GYTxRunState (..) @@ -73,7 +73,6 @@ import GeniusYield.Transaction (GYBuildTxError (GYBu GYBalancingError(GYBalancingErrorInsufficientFunds)) import GeniusYield.Transaction.Common (adjustTxOut, minimumUTxO) -import GeniusYield.Test.Address import GeniusYield.TxBuilder.Class import GeniusYield.TxBuilder.Common import GeniusYield.TxBuilder.Errors @@ -97,9 +96,6 @@ walletAddress :: Wallet -> GYAddress walletAddress Wallet{..} = addressFromPaymentKeyHash walletNetworkId $ paymentKeyHash $ paymentVerificationKey walletPaymentSigningKey -instance HasAddress Wallet where - toAddress = addressToPlutus . walletAddress - newtype GYTxRunEnv = GYTxRunEnv { runEnvWallet :: Wallet } type FeesLovelace = Sum Integer diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index 23ec290b..ec9beea0 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -80,10 +80,9 @@ import qualified Test.Tasty.QuickCheck as Tasty import qualified Test.Tasty.Runners as Tasty import GeniusYield.Imports -import GeniusYield.Test.Address import GeniusYield.Test.FakeCoin import GeniusYield.TxBuilder -import GeniusYield.TxBuilder.Clb +import GeniusYield.Test.Clb import GeniusYield.Types ------------------------------------------------------------------------------- @@ -221,19 +220,16 @@ walletPubKeyHash = fromJust . addressToPubKeyHash . walletAddress {- | Gets the balance from anything that `HasAddress`. The usual case will be a testing wallet. -} -balance :: HasAddress a => a -> GYTxMonadClb GYValue +balance :: Wallet -> GYTxMonadClb GYValue balance a = do - nid <- networkId - case addressFromPlutus nid $ toAddress a of - Left err -> fail $ show err - Right addr -> do - utxos <- utxosAtAddress addr Nothing - return $ foldMapUTxOs utxoValue utxos + let addr = walletAddress a + utxos <- utxosAtAddress addr Nothing + return $ foldMapUTxOs utxoValue utxos {- | Computes a `GYTxMonadClb` action and returns the result and how this action changed the balance of some "Address". -} -withBalance :: HasAddress a => String -> a -> GYTxMonadClb b -> GYTxMonadClb (b, GYValue) +withBalance :: String -> Wallet -> GYTxMonadClb b -> GYTxMonadClb (b, GYValue) withBalance n a m = do old <- balance a b <- m diff --git a/tests/GeniusYield/Test/RefInput.hs b/tests/GeniusYield/Test/RefInput.hs index 674204a8..0029184d 100644 --- a/tests/GeniusYield/Test/RefInput.hs +++ b/tests/GeniusYield/Test/RefInput.hs @@ -21,7 +21,7 @@ import GeniusYield.Test.GYTxBody (mockTxId) import GeniusYield.Test.OnChain.GuessRefInputDatum.Compiled import GeniusYield.Test.Utils import GeniusYield.TxBuilder -import GeniusYield.TxBuilder.Clb +import GeniusYield.Test.Clb import GeniusYield.Types gyGuessRefInputDatumValidator :: GYValidator 'PlutusV2 From 31fa45ccb3be119f41f2cd773496b76d824165ed Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Mon, 15 Jul 2024 16:03:44 -0600 Subject: [PATCH 02/15] More utilities for `User` --- src/GeniusYield/TxBuilder/User.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/GeniusYield/TxBuilder/User.hs b/src/GeniusYield/TxBuilder/User.hs index 08b9c436..9a8cb0f4 100644 --- a/src/GeniusYield/TxBuilder/User.hs +++ b/src/GeniusYield/TxBuilder/User.hs @@ -13,12 +13,14 @@ module GeniusYield.TxBuilder.User ( userStakeSKey', userStakeVKey, userCollateralDumb, + userAddresses', userAddr, ) where import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE +import GeniusYield.Imports import GeniusYield.Types.Address (GYAddress) import GeniusYield.Types.Key import GeniusYield.Types.Key.Class (ToShelleyWitnessSigningKey (toShelleyWitnessSigningKey)) @@ -33,7 +35,7 @@ data UserCollateral = UserCollateral , userCollateralCheck :: Bool -- ^ If `False` then the given `GYTxOutRef` will be used and reserved as collateral. -- If `True`, then collateral will only be used and reserved, if value in the given UTxO is exactly 5 ada. - } + } deriving stock (Eq, Show) -- | Note: When signing using 'ToShelleyWitnessSigningKey' instance, it only uses the payment signing key. data User = User @@ -42,7 +44,10 @@ data User = User , userAddresses :: !(NonEmpty GYAddress) , userChangeAddress :: !GYAddress , userCollateral :: Maybe UserCollateral - } + } deriving stock (Eq, Show) + +instance Ord User where + compare = compare `on` userChangeAddress -- | This only takes the payment signing key, not the stake key. instance ToShelleyWitnessSigningKey User where @@ -71,6 +76,9 @@ userCollateralDumb :: User -> Maybe (GYTxOutRef, Bool) userCollateralDumb User{userCollateral} = (\UserCollateral {userCollateralRef, userCollateralCheck} -> (userCollateralRef, userCollateralCheck)) <$> userCollateral +userAddresses' :: User -> [GYAddress] +userAddresses' = NE.toList . userAddresses + pattern User' :: GYPaymentSigningKey -> Maybe GYStakeSigningKey -> GYAddress -> User pattern User' { userPaymentSKey', userStakeSKey', userAddr } <- User { userPaymentSKey = userPaymentSKey' From f71d92db3c6f2bbf057fbcd19a4367c8d75bb66d Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Mon, 15 Jul 2024 16:49:34 -0600 Subject: [PATCH 03/15] Add 'FeeTracker' for a unified fee tracked balance checking interface --- atlas-cardano.cabal | 1 + src/GeniusYield/Test/FeeTracker.hs | 225 +++++++++++++++++++++++++++++ src/GeniusYield/TxBuilder/Class.hs | 3 +- 3 files changed, 228 insertions(+), 1 deletion(-) create mode 100644 src/GeniusYield/Test/FeeTracker.hs diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index 8e7d89d1..ccc0a077 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -86,6 +86,7 @@ library GeniusYield.Swagger.Utils GeniusYield.Test.Clb GeniusYield.Test.FakeCoin + GeniusYield.Test.FeeTracker GeniusYield.Test.Privnet.Asserts GeniusYield.Test.Privnet.Ctx GeniusYield.Test.Privnet.Examples diff --git a/src/GeniusYield/Test/FeeTracker.hs b/src/GeniusYield/Test/FeeTracker.hs new file mode 100644 index 00000000..ef2f6b28 --- /dev/null +++ b/src/GeniusYield/Test/FeeTracker.hs @@ -0,0 +1,225 @@ +{-| +Module : GeniusYield.Test.FeeTracker +Copyright : (c) 2023 GYELD GMBH +License : Apache 2.0 +Maintainer : support@geniusyield.co +Stability : develop + +-} + +module GeniusYield.Test.FeeTracker ( + FeeTrackerGame, + FeeTracker, + withWalletBalancesCheckSimple, + withWalletBalancesCheckSimpleIgnoreMinDepFor +) where + +import Control.Monad.Except +import Control.Monad.Random +import Control.Monad.State.Strict +import Data.Foldable (foldMap') +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M +import Data.Monoid +import qualified Data.Set as S +import qualified Data.Text as T + +import GeniusYield.HTTP.Errors (someBackendError) +import GeniusYield.Imports +import GeniusYield.TxBuilder +import GeniusYield.Types + +type FeesLovelace = Sum Integer +type MinAdaLovelace = Sum Integer + +-- | Extra lovelace consumed by tx fees and utxo min ada deposits for the transactions submitted by a user. +data UserExtraLovelace = UserExtraLovelace { uelFees :: FeesLovelace, uelMinAda :: MinAdaLovelace } + deriving stock (Eq, Ord, Show) + +instance Semigroup UserExtraLovelace where + UserExtraLovelace a b <> UserExtraLovelace x y = UserExtraLovelace (a <> x) (b <> y) + +instance Monoid UserExtraLovelace where + mempty = UserExtraLovelace mempty mempty + +-- | Track extra lovelace per transaction and submitted transactions. Only the submitted transactions' extra +-- lovelace is considered in the end. +data FeeTrackerState = FeeTrackerState { feesPerTx :: !(Map GYTxId UserExtraLovelace), submittedTxIds :: ![GYTxId] } + deriving stock (Eq, Ord, Show) + +instance Semigroup FeeTrackerState where + FeeTrackerState fees txIds <> FeeTrackerState fees' txIds' = FeeTrackerState (M.unionWith (<>) fees fees') (txIds <> txIds') + +instance Monoid FeeTrackerState where + mempty = FeeTrackerState mempty mempty + +insertFeesPerTx :: GYTxId -> UserExtraLovelace -> FeeTrackerState -> FeeTrackerState +insertFeesPerTx txId extraLovelace st = st { feesPerTx = M.insert txId extraLovelace $ feesPerTx st } + +addSubmittedTx :: GYTxId -> FeeTrackerState -> FeeTrackerState +addSubmittedTx txId st = st { submittedTxIds = txId : submittedTxIds st } + +-- | A wrapper around 'GYTxMonad' that "injects" code around transaction building and submitting to track fees. +newtype FeeTracker m a = FeeTracker (FeeTrackerState -> m (a, FeeTrackerState)) + deriving ( Functor + , Applicative + , Monad + , MonadState FeeTrackerState + , MonadRandom + , GYTxQueryMonad + , GYTxSpecialQueryMonad + , GYTxUserQueryMonad + ) + via StateT FeeTrackerState m + +-- The context cannot be inferred since it contains non-type variables (i.e 'GYTxMonadException') +-- Must use standalone deriving with explicit context. +deriving + via StateT FeeTrackerState m + instance MonadError GYTxMonadException m => MonadError GYTxMonadException (FeeTracker m) + +ftLift :: Functor m => m a -> FeeTracker m a +ftLift act = FeeTracker $ \s -> (, s) <$> act + +-- | Override given transaction building function to track extra lovelace per transaction. +wrapBodyBuilder :: GYTxUserQueryMonad m => ([GYTxSkeleton v] -> m GYTxBuildResult) -> [GYTxSkeleton v] -> FeeTracker m GYTxBuildResult +wrapBodyBuilder f skeletons = do + userAddress <- ownChangeAddress + res <- ftLift $ f skeletons + let helpers txBodies = forM_ (zip skeletons (NE.toList txBodies)) (helper userAddress) + case res of + GYTxBuildSuccess txBodies -> helpers txBodies + GYTxBuildPartialSuccess _ txBodies -> helpers txBodies + _ -> pure () + pure res + where + + helper userAddress (skeleton, txBody) = do + let txId = txBodyTxId txBody + -- Actual outputs with their blueprints (counterpart from skeleton) + -- NOTE: This relies on proper ordering. 'txBodyUTxOs txBody' is expected to have the same order + -- as the outputs in the skeleton. The extra balancing outputs at the end of the list of 'txBodyUTxOs txBody' + -- should be truncated by 'zip'. + outsWithBlueprint = zip (gytxOuts skeleton) . utxosToList $ txBodyUTxOs txBody + modify' . insertFeesPerTx txId $ UserExtraLovelace + { uelFees = Sum $ txBodyFee txBody + , uelMinAda = Sum . flip valueAssetClass GYLovelace $ + foldMap' + (\(blueprint, actual) -> + -- If this additional ada is coming back to one's own self, we need not account for it. + if gyTxOutAddress blueprint == userAddress then mempty + else utxoValue actual `valueMinus` gyTxOutValue blueprint + ) + outsWithBlueprint + } + +-- | Override transaction building code of the inner monad to track extra lovelace per transaction. +instance GYTxBuilderMonad m => GYTxBuilderMonad (FeeTracker m) where + type TxBuilderStrategy (FeeTracker m) = TxBuilderStrategy m + buildTxBodyWithStrategy strat skeleton = do + res <- wrapBodyBuilder (\x -> GYTxBuildSuccess . NE.singleton <$> buildTxBodyWithStrategy @m strat (head x)) [skeleton] + case res of + GYTxBuildSuccess bodies -> pure $ NE.head bodies + _ -> error "FeeTracker.buildTxBodyWithStrategy: Absurd" + buildTxBodyParallelWithStrategy strat = wrapBodyBuilder $ buildTxBodyParallelWithStrategy strat + buildTxBodyChainingWithStrategy strat = wrapBodyBuilder $ buildTxBodyChainingWithStrategy strat + +-- | Override transaction submitting code of the inner monad to track submitted transaction ids. +instance GYTxMonad m => GYTxMonad (FeeTracker m) where + signTxBody = ftLift . signTxBody + signTxBodyWithStake = ftLift . signTxBodyWithStake + submitTx tx = do + txId <- ftLift $ submitTx tx + modify $ addSubmittedTx txId + pure txId + awaitTxConfirmed' p = ftLift . awaitTxConfirmed' p + +-- | A wrapper around 'GYTxGameMonad' that uses 'FeeTracker' as its 'GYTxMonad' to track extra lovelaces per transaction. +newtype FeeTrackerGame m a = FeeTrackerGame (Map GYAddress FeeTrackerState -> m (a, Map GYAddress FeeTrackerState)) + deriving ( Functor + , Applicative + , Monad + , MonadState (Map GYAddress FeeTrackerState) + , MonadRandom + , GYTxQueryMonad + , GYTxSpecialQueryMonad + ) + via StateT (Map GYAddress FeeTrackerState) m + +-- The context cannot be inferred since it contains non-type variables (i.e 'GYTxMonadException') +-- Must use standalone deriving with explicit context. +deriving + via StateT (Map GYAddress FeeTrackerState) m + instance MonadError GYTxMonadException m => MonadError GYTxMonadException (FeeTrackerGame m) + +evalFtg :: Functor f => FeeTrackerGame f b -> f b +evalFtg (FeeTrackerGame act) = fst <$> act mempty + +-- | Convert 'FeeTrackerState' to the effective extra lovelace map per user. Filtering out irrelevant transactions (not submitted). +walletExtraLovelace :: Map GYAddress FeeTrackerState -> Map GYAddress UserExtraLovelace +walletExtraLovelace m = M.map (\FeeTrackerState {feesPerTx} -> foldMap snd . filter ((`S.member` validTxIds) . fst) $ M.assocs feesPerTx) m + where + validTxIds = S.fromList . concatMap submittedTxIds $ M.elems m + +ftgLift :: Functor m => m a -> FeeTrackerGame m a +ftgLift act = FeeTrackerGame $ \s -> (, s) <$> act + +instance GYTxGameMonad m => GYTxGameMonad (FeeTrackerGame m) where + type TxMonadOf (FeeTrackerGame m) = FeeTracker (TxMonadOf m) + asUser u (FeeTracker act) = FeeTrackerGame $ \s -> do + (a, innerS) <- asUser u $ act mempty + pure (a, M.insertWith (<>) (userChangeAddress u) innerS s) + waitUntilSlot = ftgLift . waitUntilSlot + waitForNextBlock = ftgLift waitForNextBlock + +{- Note [Proper GYTxMonad overriding with FeeTracker] + +It's important for the 'GYTxMonad' code block to be _instantiated_ as 'FeeTracker m' +for the appropriate code overriding to take place. Specifically, if you have a code block +of type 'GYTxMonad', which then gets type inferred and instantiated to be 'GYTxMonadClb' for +example, and then said 'GYTxMonadClb' is wrapped to obtain a 'FeeTracker GYTxMonadClb', no +overriding has taken place. + +Instead, that codeblock needs to be type inferred and instantiated to be 'FeeTracker GYTxMonadClb'. +At the end of the day, the code block is universally quantified. And therefore, its instantiation +is chosen at the call site. And the methods to fire are also chosen at the same site. + +This is why 'withWalletBalancesCheckSimple' takes a 'FeeTrackerGame m' as its input. The idea is that, +when this function is applied to a code block of type 'GYTxGameMonad', the type is then instantiated +as 'FeeTrackerGame'. With the help of our injective type family 'TxMonadOf', all the inner 'GYTxMonad's +will then be instantiated as 'FeeTracker m', and all the proper methods will now fire. The 'm' can be decided +at the very end. + +In contrast, if 'withWalletBalancesCheckSimple' took a normal 'GYTxGameMonad m => m', it might end up being inferred +and instantiated as 'GYTxMonadClb' (for example), which will then be wrapped with the 'FeeTrackerGame' constructor +within the 'withWalletBalancesCheckSimple' function body. But that will achieve no overriding, the methods have already +been chosen! +-} + +{- | Computes a 'GYTxMonadClb' action, checking that the 'Wallet' balances + change according to the input list. This is a simplified version of `withWalletBalancesCheck` where the input list need not consider lovelaces required for fees & to satisfy the min ada requirements as these are added automatically. It is therefore recommended to use this function over `withWalletBalancesCheck` to avoid hardcoding the lovelaces required for fees & min ada constraints. +Notes: +* An empty list means no checks are performed. +* The 'GYValue' should be negative to check if the Wallet lost those funds. +-} +withWalletBalancesCheckSimple :: GYTxGameMonad m => [(User, GYValue)] -> FeeTrackerGame m a -> m a +withWalletBalancesCheckSimple wallValueDiffs = withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs mempty + +-- | Variant of `withWalletBalancesCheckSimple` that only accounts for transaction fees and not minimum ada deposits. +withWalletBalancesCheckSimpleIgnoreMinDepFor :: GYTxGameMonad m => [(User, GYValue)] -> Set User -> FeeTrackerGame m a -> m a +withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs ignoreMinDepFor m = evalFtg $ do + bs <- mapM (queryBalances . userAddresses' . fst) wallValueDiffs + a <- m + walletExtraLovelaceMap <- gets walletExtraLovelace + bs' <- mapM (queryBalances . userAddresses' . fst) wallValueDiffs + + forM_ (zip3 wallValueDiffs bs' bs) $ + \((w, v), b', b) -> + let addr = userChangeAddress w + newBalance = case M.lookup addr walletExtraLovelaceMap of + Nothing -> b' + Just UserExtraLovelace {uelFees, uelMinAda} -> b' <> valueFromLovelace (getSum $ uelFees <> if w `S.member` ignoreMinDepFor then mempty else uelMinAda) + diff = newBalance `valueMinus` b + in unless (diff == v) . throwAppError . someBackendError . T.pack $ + printf "Wallet: %s. Old balance: %s. New balance: %s. New balance after adding extra lovelaces %s. Expected balance difference of %s, but the actual difference was %s" addr b b' newBalance v diff + pure a diff --git a/src/GeniusYield/TxBuilder/Class.hs b/src/GeniusYield/TxBuilder/Class.hs index b59c5bc3..c06743ac 100644 --- a/src/GeniusYield/TxBuilder/Class.hs +++ b/src/GeniusYield/TxBuilder/Class.hs @@ -344,7 +344,8 @@ instance is expected to have its own unique 'GYTxMonad' instance. So instance. The solution to this is to simply have a wrapper data type that brings generativity to the table. -Such as 'data ReaderTTxMonad m a = ReaderTTxMonad ((TxMonadOf m) a)' or similar. +Such as 'data ReaderTTxMonad m a = ReaderTTxMonad ((TxMonadOf m) a)' or similar. See +"GeniusYield.Test.FeeTracker.FeeTrackerGame" for a tutorial on how to do this. Since these wrapper data types are usage specific, and 'GYTxGameMonad' instances are meant to be some "overarching base" type, we do not provide these instances and users may define them if necessary. From 578c804a276da4320398d03126c798798e1d9910 Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Mon, 15 Jul 2024 22:27:13 -0600 Subject: [PATCH 04/15] Make 'Clb' a proper part of 'GYTx*' monad hierarchy --- src/GeniusYield/Test/Clb.hs | 275 +++++++++++++--------------------- src/GeniusYield/Test/Utils.hs | 269 ++++++++++++++------------------- 2 files changed, 214 insertions(+), 330 deletions(-) diff --git a/src/GeniusYield/Test/Clb.hs b/src/GeniusYield/Test/Clb.hs index 2e8d79be..02ec5667 100644 --- a/src/GeniusYield/Test/Clb.hs +++ b/src/GeniusYield/Test/Clb.hs @@ -9,21 +9,13 @@ Stability : develop -} module GeniusYield.Test.Clb - ( Wallet (..) - , WalletName - , GYTxRunState (..) - , GYTxMonadClb - , walletAddress + ( GYTxMonadClb , asClb , asRandClb , liftClb - , ownAddress - , sendSkeleton - , sendSkeleton' - , sendSkeletonWithWallets , dumpUtxoState , mustFail - , getNetworkId + , mustFailWith ) where import Control.Lens ((^.)) @@ -31,12 +23,7 @@ import Control.Monad.Except import Control.Monad.Random import Control.Monad.Reader import Control.Monad.State -import Data.Default (Default(def)) -import Data.Foldable (foldMap') -import Data.List (singleton) -import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as Map -import Data.Semigroup (Sum (..)) import qualified Data.Sequence as Seq import qualified Data.Set as Set import Data.SOP.NonEmpty (NonEmpty (NonEmptyCons, NonEmptyOne)) @@ -59,55 +46,33 @@ import Cardano.Slotting.Time (RelativeTime (Relati mkSlotLength) import Clb (ClbState (..), ClbT, EmulatedLedgerState (..), Log (Log), LogEntry (LogEntry), LogLevel (..), - MockConfig(..), OnChainTx, SlotConfig(..), + MockConfig(..), SlotConfig(..), ValidationResult (..), getCurrentSlot, txOutRefAt, - txOutRefAtPaymentCred, sendTx, fromLog, unLog, getFails, - logInfo, logError) + txOutRefAtPaymentCred, sendTx, unLog, getFails, + logInfo, logError, waitSlot) import qualified Clb (dumpUtxoState) +import Control.Monad.Trans.Maybe (runMaybeT) import qualified Ouroboros.Consensus.Cardano.Block as Ouroboros import qualified Ouroboros.Consensus.HardFork.History as Ouroboros import qualified PlutusLedgerApi.V2 as Plutus import GeniusYield.Imports -import GeniusYield.Transaction (GYBuildTxError (GYBuildTxBalancingError), - GYBalancingError(GYBalancingErrorInsufficientFunds)) -import GeniusYield.Transaction.Common (adjustTxOut, - minimumUTxO) import GeniusYield.TxBuilder.Class import GeniusYield.TxBuilder.Common import GeniusYield.TxBuilder.Errors +import GeniusYield.TxBuilder.User import GeniusYield.Types -- FIXME: Fix this type synonym upstream. type Clb = ClbT Identity -type WalletName = String - --- | Testing Wallet representation. -data Wallet = Wallet - { walletPaymentSigningKey :: !GYPaymentSigningKey - , walletNetworkId :: !GYNetworkId - , walletName :: !WalletName - } - deriving (Show, Eq, Ord) - --- | Gets a GYAddress of a testing wallet. -walletAddress :: Wallet -> GYAddress -walletAddress Wallet{..} = addressFromPaymentKeyHash walletNetworkId $ paymentKeyHash $ - paymentVerificationKey walletPaymentSigningKey - -newtype GYTxRunEnv = GYTxRunEnv { runEnvWallet :: Wallet } - -type FeesLovelace = Sum Integer -type MinAdaLovelace = Sum Integer - --- Used by 'withWalletBalancesCheckSimple' (not yet) -newtype GYTxRunState = GYTxRunState { walletExtraLovelace :: Map WalletName (FeesLovelace, MinAdaLovelace) } +newtype GYTxRunEnv = GYTxRunEnv { runEnvWallet :: User } newtype GYTxMonadClb a = GYTxMonadClb - { unGYTxMonadClb :: ExceptT (Either String GYTxMonadException) (StateT GYTxRunState (ReaderT GYTxRunEnv (RandT StdGen Clb))) a + { unGYTxMonadClb :: ReaderT GYTxRunEnv (ExceptT (Either String GYTxMonadException) (RandT StdGen Clb)) a } - deriving newtype (Functor, Applicative, Monad, MonadReader GYTxRunEnv, MonadState GYTxRunState) + deriving newtype (Functor, Applicative, Monad, MonadReader GYTxRunEnv) + deriving anyclass GYTxBuilderMonad instance MonadRandom GYTxMonadClb where getRandomR = GYTxMonadClb . getRandomR @@ -115,69 +80,57 @@ instance MonadRandom GYTxMonadClb where getRandomRs = GYTxMonadClb . getRandomRs getRandoms = GYTxMonadClb getRandoms -asRandClb :: Wallet +asRandClb :: User -> GYTxMonadClb a -> RandT StdGen Clb (Maybe a) asRandClb w m = do - e <- runReaderT (evalStateT (runExceptT $ unGYTxMonadClb m) $ GYTxRunState Map.empty) $ GYTxRunEnv w + e <- runExceptT $ unGYTxMonadClb m `runReaderT` GYTxRunEnv w case e of Left (Left err) -> lift (logError err) >> return Nothing Left (Right err) -> lift (logError (show err)) >> return Nothing Right a -> return $ Just a asClb :: StdGen - -> Wallet + -> User -> GYTxMonadClb a -> Clb (Maybe a) asClb g w m = evalRandT (asRandClb w m) g -ownAddress :: GYTxMonadClb GYAddress -ownAddress = do - nid <- networkId - asks $ addressFromPaymentKeyHash nid . paymentKeyHash . paymentVerificationKey . walletPaymentSigningKey . runEnvWallet - liftClb :: Clb a -> GYTxMonadClb a -liftClb = GYTxMonadClb . lift . lift . lift . lift +liftClb = GYTxMonadClb . lift . lift . lift {- | Try to execute an action, and if it fails, restore to the current state while preserving logs. If the action succeeds, logs an error as we expect - it to fail. Use 'mustFailWith' and 'mustFailWithBlock' to provide custom + it to fail. Use 'mustFailWith' to provide custom error message or/and failure action name. FIXME: should we move it to CLB? -} mustFail :: GYTxMonadClb a -> GYTxMonadClb () -mustFail act = do +mustFail = mustFailWith (const True) + +mustFailWith :: (GYTxMonadException -> Bool) -> GYTxMonadClb a -> GYTxMonadClb () +mustFailWith isExpectedError act = do (st, preFails) <- liftClb $ do st <- get preFails <- getFails pure (st, preFails) - void act - postFails <- liftClb getFails - if noNewErrors preFails postFails - then liftClb $ logError "Expected action to fail but it succeeds" - else do - infoLog <- liftClb $ gets mockInfo - liftClb $ put - st - { mockInfo = infoLog <> mkMustFailLog preFails postFails - -- , mustFailLog = mkMustFailLog preFails postFails - } + tryError (void act) >>= \case + Left e@(isExpectedError -> True) -> do + gyLogInfo' "" . printf "Successfully caught expected exception %s" $ show e + infoLog <- liftClb $ gets mockInfo + postFails <- liftClb getFails + liftClb $ put + st + { mockInfo = infoLog <> mkMustFailLog preFails postFails + -- , mustFailLog = mkMustFailLog preFails postFails + } + Left err -> liftClb $ logError $ "Action failed with unexpected exception: " ++ show err + Right _ -> liftClb $ logError "Expected action to fail but it succeeds" where - noNewErrors (fromLog -> a) (fromLog -> b) = length a == length b mkMustFailLog (unLog -> pre) (unLog -> post) = Log $ second (LogEntry Error . ((msg <> ":") <> ). show) <$> Seq.drop (Seq.length pre) post msg = "Unnamed failure action" -getNetworkId :: GYTxMonadClb GYNetworkId -getNetworkId = do - magic <- liftClb $ gets (mockConfigNetworkId . mockConfig) - -- TODO: Add epoch slots and network era to clb and retrieve from there. - pure . GYPrivnet $ GYNetworkInfo - { gyNetworkMagic = Api.S.unNetworkMagic $ Api.S.toNetworkMagic magic - , gyNetworkEpochSlots = 500 - , gyNetworkEra = GYBabbage - } - instance MonadFail GYTxMonadClb where fail = GYTxMonadClb . throwError . Left @@ -191,7 +144,14 @@ instance MonadError GYTxMonadException GYTxMonadClb where instance GYTxQueryMonad GYTxMonadClb where - networkId = getNetworkId + networkId = do + magic <- liftClb $ gets (mockConfigNetworkId . mockConfig) + -- TODO: Add epoch slots and network era to clb and retrieve from there. + pure . GYPrivnet $ GYNetworkInfo + { gyNetworkMagic = Api.S.unNetworkMagic $ Api.S.toNetworkMagic magic + , gyNetworkEpochSlots = 500 + , gyNetworkEra = GYBabbage + } lookupDatum :: GYDatumHash -> GYTxMonadClb (Maybe GYDatum) lookupDatum h = liftClb $ do @@ -287,13 +247,16 @@ instance GYTxQueryMonad GYTxMonadClb where instance GYTxUserQueryMonad GYTxMonadClb where - ownAddresses = singleton <$> do - nid <- networkId - asks $ addressFromPaymentKeyHash nid . paymentKeyHash . paymentVerificationKey . walletPaymentSigningKey . runEnvWallet + ownAddresses = asks $ userAddresses' . runEnvWallet - ownChangeAddress = head <$> ownAddresses + ownChangeAddress = asks $ userChangeAddress . runEnvWallet - ownCollateral = pure Nothing + ownCollateral = runMaybeT $ do + UserCollateral {userCollateralRef, userCollateralCheck} <- asks (userCollateral . runEnvWallet) >>= hoistMaybe + collateralUtxo <- lift $ utxoAtTxOutRef userCollateralRef + >>= maybe (throwError . GYQueryUTxOException $ GYNoUtxoAtRef userCollateralRef) pure + if not userCollateralCheck || (utxoValue collateralUtxo == collateralValue) then pure collateralUtxo + else hoistMaybe Nothing availableUTxOs = do addrs <- ownAddresses @@ -312,94 +275,61 @@ instance GYTxUserQueryMonad GYTxMonadClb where Just u -> return $ utxoRef u Nothing -> throwError . GYQueryUTxOException $ GYNoUtxosAtAddress addrs -- TODO: Better error message here? --- Send skeletons with multiple signatures from wallet -sendSkeletonWithWallets :: GYTxSkeleton v -> [Wallet] -> GYTxMonadClb GYTxId -sendSkeletonWithWallets skeleton ws = snd <$> sendSkeleton' skeleton ws - -sendSkeleton :: GYTxSkeleton v -> GYTxMonadClb GYTxId -sendSkeleton skeleton = snd <$> sendSkeleton' skeleton [] - -sendSkeleton' :: GYTxSkeleton v -> [Wallet] -> GYTxMonadClb (OnChainTx, GYTxId) -sendSkeleton' skeleton ws = do - w <- asks runEnvWallet - let sigs = map walletPaymentSigningKey $ w : ws - body <- skeletonToTxBody skeleton - pp <- protocolParameters - modify (updateWalletState w pp body) - dumpBody body - - let tx = signGYTxBody body sigs - gyLogDebug' "" $ "encoded tx: " <> txToHex tx - - -- Submit - vRes <- liftClb $ sendTx $ txToApi tx - case vRes of - Success _state onChainTx -> pure (onChainTx, txBodyTxId body) - Fail _ err -> fail $ show err - - where - -- Updates the wallet state. - -- Updates extra lovelace required for fees & minimum ada requirements against the wallet sending this transaction. - updateWalletState :: Wallet -> AlonzoCore.PParams (Api.S.ShelleyLedgerEra Api.S.BabbageEra) -> GYTxBody -> GYTxRunState -> GYTxRunState - updateWalletState w@Wallet {..} pp body GYTxRunState {..} = GYTxRunState $ Map.insertWith mappend walletName v walletExtraLovelace +instance GYTxMonad GYTxMonadClb where + signTxBody = signTxBodyImpl . asks $ userPaymentSKey . runEnvWallet + signTxBodyWithStake = signTxBodyWithStakeImpl $ asks ((,) . userPaymentSKey . runEnvWallet) <*> asks (userStakeSKey . runEnvWallet) + submitTx tx = do + let txBody = getTxBody tx + dumpBody txBody + gyLogDebug' "" $ "encoded tx: " <> txToHex tx + vRes <- liftClb . sendTx $ txToApi tx + case vRes of + Success _state _onChainTx -> pure $ txBodyTxId txBody + Fail _ err -> fail $ show err where - v = ( coerce $ txBodyFee body - , coerce $ flip valueAssetClass GYLovelace $ - foldMap' - (\o -> - -- If this additional ada is coming back to one's own self, we need not account for it. - if gyTxOutAddress o == walletAddress w then - mempty - else gyTxOutValue (adjustTxOut (minimumUTxO pp) o) `valueMinus` gyTxOutValue o - ) $ gytxOuts skeleton - ) - - -- TODO: use Prettyprinter - dumpBody :: GYTxBody -> GYTxMonadClb () - dumpBody body = do - ins <- mapM utxoAtTxOutRef' $ txBodyTxIns body - refIns <- mapM utxoAtTxOutRef' $ txBodyTxInsReference body - gyLogDebug' "" $ - printf "fee: %d lovelace\nmint value: %s\nvalidity range: %s\ncollateral: %s\ntotal collateral: %d\ninputs:\n\n%sreference inputs:\n\n%soutputs:\n\n%s" - (txBodyFee body) - (txBodyMintValue body) - (show $ txBodyValidityRange body) - (show $ txBodyCollateral body) - (txBodyTotalCollateralLovelace body) - (concatMap dumpInUTxO ins) - (concatMap dumpInUTxO refIns) - (concatMap dumpOutUTxO $ utxosToList $ txBodyUTxOs body) - - dumpInUTxO :: GYUTxO -> String - dumpInUTxO GYUTxO{..} = printf " - ref: %s\n" utxoRef <> - printf " addr: %s\n" utxoAddress <> - printf " value: %s\n" utxoValue <> - printf " datum: %s\n" (show utxoOutDatum) <> - printf " ref script: %s\n\n" (show utxoRefScript) - - dumpOutUTxO :: GYUTxO -> String - dumpOutUTxO GYUTxO{..} = printf " - addr: %s\n" utxoAddress <> - printf " value: %s\n" utxoValue <> - printf " datum: %s\n" (show utxoOutDatum) <> - printf " ref script: %s\n\n" (show utxoRefScript) - -skeletonToTxBody :: GYTxSkeleton v -> GYTxMonadClb GYTxBody -skeletonToTxBody skeleton = do - ss <- systemStart - eh <- eraHistory - pp <- protocolParameters - ps <- stakePools - - addr <- ownAddress - e <- buildTxCore ss eh pp ps def (const id) [addr] addr Nothing [skeleton] - case e of - Left err -> throwError $ GYBuildTxException err - Right res -> case res of - GYTxBuildSuccess (body :| _) -> return body - GYTxBuildFailure (GYBalancingErrorInsufficientFunds v) -> throwError . GYBuildTxException . GYBuildTxBalancingError $ GYBalancingErrorInsufficientFunds v - GYTxBuildFailure _ -> error "impossible case" - GYTxBuildPartialSuccess _ _ -> error "impossible case" - GYTxBuildNoInputs -> error "impossible case" + -- TODO: use Prettyprinter + dumpBody :: GYTxBody -> GYTxMonadClb () + dumpBody body = do + ins <- mapM utxoAtTxOutRef' $ txBodyTxIns body + refIns <- mapM utxoAtTxOutRef' $ txBodyTxInsReference body + gyLogDebug' "" $ + printf "fee: %d lovelace\nmint value: %s\nvalidity range: %s\ncollateral: %s\ntotal collateral: %d\ninputs:\n\n%sreference inputs:\n\n%soutputs:\n\n%s" + (txBodyFee body) + (txBodyMintValue body) + (show $ txBodyValidityRange body) + (show $ txBodyCollateral body) + (txBodyTotalCollateralLovelace body) + (concatMap dumpInUTxO ins) + (concatMap dumpInUTxO refIns) + (concatMap dumpOutUTxO $ utxosToList $ txBodyUTxOs body) + + dumpInUTxO :: GYUTxO -> String + dumpInUTxO GYUTxO{..} = printf " - ref: %s\n" utxoRef <> + printf " addr: %s\n" utxoAddress <> + printf " value: %s\n" utxoValue <> + printf " datum: %s\n" (show utxoOutDatum) <> + printf " ref script: %s\n\n" (show utxoRefScript) + + dumpOutUTxO :: GYUTxO -> String + dumpOutUTxO GYUTxO{..} = printf " - addr: %s\n" utxoAddress <> + printf " value: %s\n" utxoValue <> + printf " datum: %s\n" (show utxoOutDatum) <> + printf " ref script: %s\n\n" (show utxoRefScript) + + -- Transaction submission and confirmation is immediate in CLB. + awaitTxConfirmed' _ _ = pure () + +instance GYTxGameMonad GYTxMonadClb where + type TxMonadOf GYTxMonadClb = GYTxMonadClb + asUser u act = do + local + (const $ GYTxRunEnv u) + act + waitUntilSlot slot = do + -- Silently returns if the given slot is greater than the current slot. + liftClb . Clb.waitSlot $ slotToApi slot + pure slot + waitForNextBlock = slotOfCurrentBlock slotConfig' :: GYTxMonadClb (UTCTime, NominalDiffTime) slotConfig' = liftClb $ do @@ -418,7 +348,6 @@ instance GYTxSpecialQueryMonad GYTxMonadClb where protocolParams = Api.S.fromLedgerPParams Api.ShelleyBasedEraBabbage <$> protocolParameters - stakePools = pure Set.empty -- stakePools = do -- pids <- liftClb $ gets $ Map.keys . stake'pools . mockStake diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index ec9beea0..0c84b32a 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -12,19 +12,11 @@ module GeniusYield.Test.Utils ( Clb.Clb , mkTestFor , Wallets (..) - , runWallet - , runWallet' - , walletAddress - , walletPubKeyHash - , balance , withBalance , withWalletBalancesCheck - , withWalletBalancesCheckSimple - , withWalletBalancesCheckSimpleIgnoreMinDepFor - , getBalance - , getBalances , findLockedUtxosInBody - , utxosInBody + , getRefInfos + , findRefScriptsInBody , addRefScript , addRefInput , fakeCoin, fakeGold, fakeIron @@ -37,38 +29,28 @@ module GeniusYield.Test.Utils import Control.Lens ((^.)) import Control.Monad.Random -import Control.Monad.State import Data.List (findIndex) import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust) -import Data.Semigroup (Sum (getSum)) -import qualified Data.Maybe.Strict as StrictMaybe import qualified Data.Sequence.Strict as StrictSeq -import qualified Data.Set as Set import Prettyprinter (PageWidth (AvailablePerLine), defaultLayoutOptions, layoutPageWidth, layoutPretty) import Prettyprinter.Render.String (renderString) -import qualified Cardano.Api as Api import qualified Cardano.Api.Shelley as Api.S import qualified Cardano.Ledger.Address as L import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Babbage.Tx as L.B import qualified Cardano.Ledger.Babbage.TxOut as L.B import qualified Cardano.Ledger.Binary as L -import qualified Cardano.Ledger.Plutus.TxInfo as L.Plutus -import qualified Cardano.Ledger.Shelley.API as L.S import qualified Clb (Clb, ClbState (mockInfo), ClbT, LogEntry (..), LogLevel (..), MockConfig, - OnChainTx (getOnChainTx), checkErrors, defaultBabbage, initClb, intToKeyPair, - logInfo, ppLog, runClb, - waitSlot) + logInfo, ppLog, runClb) import qualified PlutusLedgerApi.V1.Value as Plutus import qualified PlutusLedgerApi.V2 as PlutusV2 @@ -84,6 +66,8 @@ import GeniusYield.Test.FakeCoin import GeniusYield.TxBuilder import GeniusYield.Test.Clb import GeniusYield.Types +import GeniusYield.HTTP.Errors +import Control.Monad.Except ------------------------------------------------------------------------------- -- tasty tools @@ -155,15 +139,15 @@ mkTestFor name action = fakeIron 1_000_000 wallets :: Wallets - wallets = Wallets (mkSimpleWallet "w1" (Clb.intToKeyPair 1)) - (mkSimpleWallet "w2" (Clb.intToKeyPair 2)) - (mkSimpleWallet "w3" (Clb.intToKeyPair 3)) - (mkSimpleWallet "w4" (Clb.intToKeyPair 4)) - (mkSimpleWallet "w5" (Clb.intToKeyPair 5)) - (mkSimpleWallet "w6" (Clb.intToKeyPair 6)) - (mkSimpleWallet "w7" (Clb.intToKeyPair 7)) - (mkSimpleWallet "w8" (Clb.intToKeyPair 8)) - (mkSimpleWallet "w9" (Clb.intToKeyPair 9)) + wallets = Wallets (mkSimpleWallet (Clb.intToKeyPair 1)) + (mkSimpleWallet (Clb.intToKeyPair 2)) + (mkSimpleWallet (Clb.intToKeyPair 3)) + (mkSimpleWallet (Clb.intToKeyPair 4)) + (mkSimpleWallet (Clb.intToKeyPair 5)) + (mkSimpleWallet (Clb.intToKeyPair 6)) + (mkSimpleWallet (Clb.intToKeyPair 7)) + (mkSimpleWallet (Clb.intToKeyPair 8)) + (mkSimpleWallet (Clb.intToKeyPair 9)) -- | Helper for building tests testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.MockConfig -> String -> Clb.Clb a -> Tasty.TestTree @@ -180,60 +164,37 @@ mkTestFor name action = logString = renderString $ layoutPretty options logDoc - mkSimpleWallet :: WalletName -> TL.KeyPair r L.StandardCrypto -> Wallet - mkSimpleWallet n kp = - Wallet - { walletPaymentSigningKey = paymentSigningKeyFromLedgerKeyPair kp - , walletNetworkId = GYTestnetPreprod - , walletName = n - } + mkSimpleWallet :: TL.KeyPair r L.StandardCrypto -> User + mkSimpleWallet kp = + let key = paymentSigningKeyFromLedgerKeyPair kp + in User' + { userPaymentSKey' = key + , userStakeSKey' = Nothing + , userAddr = addressFromPaymentKeyHash GYTestnetPreprod . paymentKeyHash $ + paymentVerificationKey key + } -- | Available wallets. data Wallets = Wallets - { w1 :: !Wallet - , w2 :: !Wallet - , w3 :: !Wallet - , w4 :: !Wallet - , w5 :: !Wallet - , w6 :: !Wallet - , w7 :: !Wallet - , w8 :: !Wallet - , w9 :: !Wallet + { w1 :: !User + , w2 :: !User + , w3 :: !User + , w4 :: !User + , w5 :: !User + , w6 :: !User + , w7 :: !User + , w8 :: !User + , w9 :: !User } deriving (Show, Eq, Ord) --- | Runs a `GYTxMonadClb` action using the given wallet. -runWallet :: Wallet -> GYTxMonadClb a -> GYTxMonadClb (Maybe a) -runWallet w action = liftClb $ flip evalRandT pureGen $ asRandClb w action - --- | Version of `runWallet` that fails if `Nothing` is returned by the action. -runWallet' :: Wallet -> GYTxMonadClb a -> GYTxMonadClb a -runWallet' w action = do - ma <- runWallet w action - case ma of - Nothing -> fail $ printf "Run wallet action returned Nothing" - Just a -> return a - --- | Gets a GYPubKeyHash of a testing wallet. -walletPubKeyHash :: Wallet -> GYPubKeyHash -walletPubKeyHash = fromJust . addressToPubKeyHash . walletAddress - -{- | Gets the balance from anything that `HasAddress`. The usual case will be a - testing wallet. --} -balance :: Wallet -> GYTxMonadClb GYValue -balance a = do - let addr = walletAddress a - utxos <- utxosAtAddress addr Nothing - return $ foldMapUTxOs utxoValue utxos - {- | Computes a `GYTxMonadClb` action and returns the result and how this action changed the balance of some "Address". -} -withBalance :: String -> Wallet -> GYTxMonadClb b -> GYTxMonadClb (b, GYValue) +withBalance :: String -> User -> GYTxMonadClb b -> GYTxMonadClb (b, GYValue) withBalance n a m = do - old <- balance a + old <- queryBalance $ userAddr a b <- m - new <- balance a + new <- queryBalance $ userAddr a let diff = new `valueMinus` old gyLogDebug' "" $ printf "%s:\nold balance: %s\nnew balance: %s\ndiff: %s" n old new diff return (b, diff) @@ -244,56 +205,19 @@ Notes: * An empty list means no checks are performed. * The 'GYValue' should be negative to check if the Wallet lost those funds. -} -withWalletBalancesCheck :: [(Wallet, GYValue)] -> GYTxMonadClb a -> GYTxMonadClb a +withWalletBalancesCheck :: [(User, GYValue)] -> GYTxMonadClb a -> GYTxMonadClb a withWalletBalancesCheck [] m = m withWalletBalancesCheck ((w, v) : xs) m = do - (b, diff) <- withBalance (walletName w) w $ withWalletBalancesCheck xs m + (b, diff) <- withBalance (show $ userAddr w) w $ withWalletBalancesCheck xs m unless (diff == v) $ do - fail $ printf "expected balance difference of %s for wallet %s, but the actual difference was %s" v (walletName w) diff + fail $ printf "expected balance difference of %s for wallet %s, but the actual difference was %s" v (userAddr w) diff return b -{- | Computes a 'GYTxMonadClb' action, checking that the 'Wallet' balances - change according to the input list. This is a simplified version of `withWalletBalancesCheck` where the input list need not consider lovelaces required for fees & to satisfy the min ada requirements as these are added automatically. It is therefore recommended to use this function over `withWalletBalancesCheck` to avoid hardcoding the lovelaces required for fees & min ada constraints. -Notes: -* An empty list means no checks are performed. -* The 'GYValue' should be negative to check if the Wallet lost those funds. --} -withWalletBalancesCheckSimple :: [(Wallet, GYValue)] -> GYTxMonadClb a -> GYTxMonadClb a -withWalletBalancesCheckSimple wallValueDiffs = withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs mempty - --- | Variant of `withWalletBalancesCheckSimple` that only accounts for transaction fees and not minimum ada deposits. -withWalletBalancesCheckSimpleIgnoreMinDepFor :: [(Wallet, GYValue)] -> Set WalletName -> GYTxMonadClb a -> GYTxMonadClb a -withWalletBalancesCheckSimpleIgnoreMinDepFor wallValueDiffs ignoreMinDepFor m = do - bs <- mapM (balance . fst) wallValueDiffs - a <- m - walletExtraLovelaceMap <- gets walletExtraLovelace - bs' <- mapM (balance . fst) wallValueDiffs - - forM_ (zip3 wallValueDiffs bs' bs) $ - \((w, v), b', b) -> - let wn = walletName w - newBalance = case Map.lookup wn walletExtraLovelaceMap of - Nothing -> b' - Just (extraLovelaceForFees, extraLovelaceForMinAda) -> b' <> valueFromLovelace (getSum $ extraLovelaceForFees <> if Set.member wn ignoreMinDepFor then mempty else extraLovelaceForMinAda) - diff = newBalance `valueMinus` b - in unless (diff == v) $ fail $ - printf "Wallet: %s. Old balance: %s. New balance: %s. New balance after adding extra lovelaces %s. Expected balance difference of %s, but the actual difference was %s" (walletName w) b b' newBalance v diff - return a - - --- | Given a wallet returns its balance. -getBalance :: HasCallStack => Wallet -> GYTxMonadClb GYValue -getBalance w = fromJust <$> runWallet w (balance w) - --- | Given a list of wallets returns its balances. -getBalances :: HasCallStack => [Wallet] -> GYTxMonadClb [GYValue] -getBalances = mapM getBalance - {- | Returns the list of outputs of the transaction for the given address. Returns Nothing if it fails to decode an address contained in the transaction outputs. -} -findLockedUtxosInBody :: Num a => GYAddress -> Clb.OnChainTx -> Maybe [a] +findLockedUtxosInBody :: Num a => GYAddress -> GYTx -> Maybe [a] findLockedUtxosInBody addr tx = let os = getTxOutputs tx @@ -306,66 +230,97 @@ findLockedUtxosInBody addr tx = in findAllMatches (0, os, []) --- | Given a transaction and the corresponding transaction id, gives the list of UTxOs generated by that body /provided they still exist/. This function is usually expected to be called immediately after the transaction's submission. -utxosInBody :: Clb.OnChainTx -> GYTxId -> GYTxMonadClb [Maybe GYUTxO] -utxosInBody tx txId = do - let os = getTxOutputs tx - mapM (\i -> utxoAtTxOutRef (txOutRefFromTuple (txId, fromInteger $ toInteger i))) [0 .. (length os - 1)] +-- | Find reference scripts at given address. +getRefInfos :: GYTxQueryMonad m => GYAddress -> m (Map (Some GYScript) GYTxOutRef) +getRefInfos addr = do + utxo <- utxosAtAddress addr Nothing + return $ utxoToRefMap utxo +utxoToRefMap :: GYUTxOs -> Map (Some GYScript) GYTxOutRef +utxoToRefMap utxo = Map.fromList + [ (sc, ref) + | GYUTxO { utxoRef = ref, utxoRefScript = Just sc} <- utxosToList utxo + ] --- | Adds the given script to the given address and returns the reference for it. -addRefScript :: GYAddress -> GYValidator 'PlutusV2 -> GYTxMonadClb (Maybe GYTxOutRef) -addRefScript addr script = do - let script' = validatorToScript script - (tx, txId) <- sendSkeleton' (mustHaveOutput (mkGYTxOutNoDatum addr mempty) { gyTxOutRefS = Just $ GYPlutusScript script' }) [] +-- | Find reference scripts in transaction body. +findRefScriptsInBody :: GYTxBody -> Map (Some GYScript) GYTxOutRef +findRefScriptsInBody body = do + let utxo = txBodyUTxOs body + utxoToRefMap utxo - let index = findIndex - (\o -> - let lsh = fmap (apiHashToPlutus . Api.ScriptHash) $ L.hashScript <$> (o ^. L.B.referenceScriptBabbageTxOutL) - in lsh == StrictMaybe.SJust (scriptPlutusHash script') - ) - $ getTxOutputs tx - return $ (Just . txOutRefFromApiTxIdIx (txIdToApi txId) . wordToApiIx . fromInteger) . toInteger =<< index +-- | Adds the given script to the given address and returns the reference for it. +addRefScript :: forall m. GYTxMonad m => GYAddress -> GYScript 'PlutusV2 -> m GYTxOutRef +addRefScript addr sc = throwAppError absurdError `runEagerT` do + existingUtxos <- lift $ utxosAtAddress addr Nothing + let refs = utxoToRefMap existingUtxos + maybeToEager $ Map.lookup (Some sc) refs + txBody <- lift $ buildTxBody + $ mustHaveOutput GYTxOut + { gyTxOutAddress = addr + , gyTxOutValue = mempty + , gyTxOutDatum = Just (unitDatum, GYTxOutUseInlineDatum) + , gyTxOutRefS = Just $ GYPlutusScript sc + } + lift $ signAndSubmitConfirmed_ txBody + maybeToEager . Map.lookup (Some sc) $ findRefScriptsInBody txBody + where + -- The above function is written utilizing 'ExceptT' as a "eager" transformer. + -- 'Left' does not indicate failure, rather it indicates that "target value has + -- been obtained" and that we can exit eagerly. + -- | If we have a 'Just' value, we can exit with it immediately. So it gets converted + -- to 'Left'. + maybeToEager :: Maybe a -> ExceptT a m () + maybeToEager (Just a) = throwError a + maybeToEager Nothing = pure () + absurdError = someBackendError "Shouldn't happen: no ref in body" + -- If all goes well, we should finish with a 'Left'. if not, we perform the + -- given action to signal error. + runEagerT :: m a -> ExceptT a m () -> m a + runEagerT whenError = runExceptT >=> either pure (const whenError) -- | Adds an input (whose datum we'll refer later) and returns the reference to it. -addRefInput:: Bool -- ^ Whether to inline this datum? - -> GYAddress -- ^ Where to place this output? - -> GYDatum -- ^ Our datum. - -> GYTxMonadClb (Maybe GYTxOutRef) +addRefInput :: GYTxMonad m + => Bool -- ^ Whether to inline this datum? + -> GYAddress -- ^ Where to place this output? + -> GYDatum -- ^ Our datum. + -> m (Maybe GYTxOutRef) addRefInput toInline addr dat = do - (tx, txId) <- sendSkeleton' + txBody <- buildTxBody (mustHaveOutput $ GYTxOut addr mempty (Just (dat, if toInline then GYTxOutUseInlineDatum else GYTxOutDontUseInlineDatum)) Nothing ) - [] + tx@(txToApi -> Api.S.ShelleyTx _ ledgerTx) <- signTxBody txBody + txId <- submitTxConfirmed tx - outputsWithResolvedDatums <- mapM - (\o -> - resolveDatumFromLedger $ o ^. L.B.datumBabbageTxOutL - ) - $ getTxOutputs tx + let L.TxDats datumMap = ledgerTx ^. L.witsTxL . L.datsTxWitsL + datumWits = datumFromLedgerData <$> datumMap + let outputsWithResolvedDatums = map + (\o -> + resolveDatumFromLedger datumWits $ o ^. L.B.datumBabbageTxOutL + ) + $ getTxOutputs tx let mIndex = findIndex (\d -> Just dat == d) outputsWithResolvedDatums pure $ (Just . txOutRefFromApiTxIdIx (txIdToApi txId) . wordToApiIx . fromInteger) . toInteger =<< mIndex -resolveDatumFromLedger :: (GYTxQueryMonad m, L.Era era) => L.Datum era -> m (Maybe GYDatum) -resolveDatumFromLedger (L.Datum d) = pure - . Just - . datumFromPlutusData - . PlutusV2.BuiltinData - . L.getPlutusData - $ L.binaryDataToData d -resolveDatumFromLedger (L.DatumHash dh) = lookupDatum . unsafeDatumHashFromPlutus $ L.Plutus.transDataHash dh -resolveDatumFromLedger L.NoDatum = pure Nothing +resolveDatumFromLedger :: L.Era era => Map (L.DataHash (L.EraCrypto era)) GYDatum -> L.Datum era -> Maybe GYDatum +resolveDatumFromLedger _ (L.Datum d) = Just + . datumFromLedgerData + $ L.binaryDataToData d +resolveDatumFromLedger datumMap (L.DatumHash dh) = Map.lookup dh datumMap +resolveDatumFromLedger _ L.NoDatum = Nothing -- TODO: Add to CLB upstream? -getTxOutputs :: Clb.OnChainTx -> [L.B.BabbageTxOut (L.BabbageEra L.StandardCrypto)] -getTxOutputs = fmap L.sizedValue +getTxOutputs :: GYTx -> [L.B.BabbageTxOut (L.BabbageEra L.StandardCrypto)] +getTxOutputs (txToApi -> Api.S.ShelleyTx _ ledgerTx) = fmap L.sizedValue . toList . StrictSeq.fromStrict . L.B.btbOutputs - . L.B.body - . L.S.extractTx - . Clb.getOnChainTx + $ L.B.body ledgerTx + +datumFromLedgerData :: L.Data era -> GYDatum +datumFromLedgerData = datumFromPlutusData + . PlutusV2.BuiltinData + . L.getPlutusData {- | Abstraction for explicitly building a Value representing the fees of a transaction. From b2690eb8436b64b665dcef954158047fb9c02df2 Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Mon, 15 Jul 2024 22:27:28 -0600 Subject: [PATCH 05/15] Unified testing interface demonstrated by RefInput --- tests/GeniusYield/Test/RefInput.hs | 64 +++++++++++++++--------------- 1 file changed, 31 insertions(+), 33 deletions(-) diff --git a/tests/GeniusYield/Test/RefInput.hs b/tests/GeniusYield/Test/RefInput.hs index 0029184d..803619de 100644 --- a/tests/GeniusYield/Test/RefInput.hs +++ b/tests/GeniusYield/Test/RefInput.hs @@ -17,11 +17,13 @@ import Test.Tasty (TestTree, testGroup) import GeniusYield.Imports -import GeniusYield.Test.GYTxBody (mockTxId) +import GeniusYield.HTTP.Errors +import GeniusYield.Test.Clb +import GeniusYield.Test.FeeTracker import GeniusYield.Test.OnChain.GuessRefInputDatum.Compiled import GeniusYield.Test.Utils +import GeniusYield.Transaction import GeniusYield.TxBuilder -import GeniusYield.Test.Clb import GeniusYield.Types gyGuessRefInputDatumValidator :: GYValidator 'PlutusV2 @@ -31,10 +33,12 @@ refInputTests :: TestTree refInputTests = testGroup "Reference Input" [ mkTestFor "Inlined datum" $ refInputTrace True 5 5 , mkTestFor "Inlined datum - Wrong guess" $ mustFail . refInputTrace True 5 4 - , mkTestFor "Reference input must not be consumed" tryRefInputConsume + , mkTestFor "Reference input must not be consumed" $ + mustFailWith (\case { GYBuildTxException (GYBuildTxBalancingError (GYBalancingErrorInsufficientFunds _)) -> True; _ -> False }) + . tryRefInputConsume ] -guessRefInputRun :: GYTxOutRef -> GYTxOutRef -> Integer -> GYTxMonadClb () +guessRefInputRun :: GYTxMonad m => GYTxOutRef -> GYTxOutRef -> Integer -> m () guessRefInputRun refInputORef consumeRef guess = do let redeemer = Guess guess skeleton :: GYTxSkeleton 'PlutusV2 = @@ -46,49 +50,43 @@ guessRefInputRun refInputORef consumeRef guess = do (redeemerFromPlutusData redeemer) } <> mustHaveRefInput refInputORef - void $ sendSkeleton skeleton + buildTxBody skeleton >>= signAndSubmitConfirmed_ -refInputTrace :: Bool -> Integer -> Integer -> Wallets -> GYTxMonadClb () +refInputTrace :: GYTxGameMonad m => Bool -> Integer -> Integer -> Wallets -> m () refInputTrace toInline actual guess Wallets{..} = do let myGuess :: Integer = guess outValue :: GYValue = valueFromLovelace 20_000_000 - mMOref <- runWallet w1 $ addRefInput toInline (walletAddress w9) (datumFromPlutusData (RefInputDatum actual)) + mMOref <- asUser w1 $ addRefInput toInline (userAddr w9) (datumFromPlutusData (RefInputDatum actual)) case mMOref of - Nothing -> fail "Unable to create utxo to reference" - Just Nothing -> fail "Couldn't find index for reference utxo in outputs" - Just (Just refInputORef) -> - void $ runWallet w1 $ withWalletBalancesCheckSimple [w1 := valueFromLovelace 0] $ do - liftClb $ logInfoS $ printf "Reference input ORef %s" refInputORef + Nothing -> throwAppError $ someBackendError "Couldn't find index for reference utxo in outputs" + Just refInputORef -> + withWalletBalancesCheckSimple [w1 := valueFromLovelace 0] . asUser w1 $ do + gyLogInfo' "" $ printf "Reference input ORef %s" refInputORef addr <- scriptAddress gyGuessRefInputDatumValidator - (tx, txId) <- sendSkeleton' (mustHaveOutput $ mkGYTxOut addr outValue (datumFromPlutusData ())) [] + txBody <- buildTxBody . mustHaveOutput $ mkGYTxOut addr outValue (datumFromPlutusData ()) + tx <- signTxBody txBody + txId <- submitTxConfirmed tx let mOrefIndices = findLockedUtxosInBody addr tx - orefIndices <- maybe (fail "Unable to get GYAddress from some Plutus.Address in txBody") return mOrefIndices + orefIndices <- maybe (throwAppError . someBackendError $ "Unable to get GYAddress from some Plutus.Address in txBody") return mOrefIndices oref <- case fmap (txOutRefFromApiTxIdIx (txIdToApi txId) . wordToApiIx) orefIndices of [oref'] -> return oref' - _non_singleton -> fail "expected exactly one reference" - liftClb $ logInfoS $ printf "Locked ORef %s" oref + _non_singleton -> throwAppError . someBackendError $ "expected exactly one reference" + gyLogInfo' "" $ printf "Locked ORef %s" oref guessRefInputRun refInputORef oref myGuess -tryRefInputConsume :: Wallets -> GYTxMonadClb () +tryRefInputConsume :: GYTxGameMonad m => Wallets -> m () tryRefInputConsume Wallets{..} = do -- Approach: Create a new output with 60% of total ada. Mark this UTxO as reference input and try sending this same 60%, or any amount greater than 40% of this original balance. Since coin balancer can't consume this UTxO, it won't be able to build for it. - void $ runWallet w1 $ do - walletBalance <- balance w1 + void $ asUser w1 $ do + walletBalance <- queryBalance $ userAddr w1 let walletLovelaceBalance = fst $ valueSplitAda walletBalance lovelaceToSend = (walletLovelaceBalance `div` 10) * 6 -- send 60% of total ada lovelaceToSendValue = valueFromLovelace lovelaceToSend - (tx, txId) <- sendSkeleton' (mustHaveOutput $ mkGYTxOutNoDatum (walletAddress w1) lovelaceToSendValue) [] - bodyUtxos <- utxosInBody tx txId - let bodyUtxos' = catMaybes bodyUtxos - unless (length bodyUtxos == length bodyUtxos') $ fail $ printf "Shouldn't happen: Not all UTxOs reflected, originally %s but got %s and they are %s" (show $ length bodyUtxos) (show $ length bodyUtxos') (show bodyUtxos') - desiredOutputRef <- case utxoRef <$> find (\GYUTxO{ utxoValue } -> utxoValue == lovelaceToSendValue) bodyUtxos' of - Nothing -> fail "Shouldn't happen: Couldn't find the desired UTxO" + txBody <- buildTxBody . mustHaveOutput $ mkGYTxOutNoDatum (userAddr w1) lovelaceToSendValue + signAndSubmitConfirmed_ txBody + let bodyUtxos = utxosToList $ txBodyUTxOs txBody + desiredOutputRef <- case utxoRef <$> find (\GYUTxO{ utxoValue } -> utxoValue == lovelaceToSendValue) bodyUtxos of + Nothing -> throwAppError . someBackendError $ "Shouldn't happen: Couldn't find the desired UTxO" Just ref -> pure ref - sendSkeleton (mustHaveRefInput @'PlutusV2 desiredOutputRef <> mustHaveOutput (mkGYTxOutNoDatum (walletAddress w1) lovelaceToSendValue)) - `catchError` ( - \case - GYApplicationException e -> do - liftClb $ logInfoS $ printf "Successfully caught expected exception %s" (show e) - pure mockTxId - e -> fail $ printf "Unexpected exception %s" (show e) - ) + buildTxBody (mustHaveRefInput @'PlutusV2 desiredOutputRef <> mustHaveOutput (mkGYTxOutNoDatum (userAddr w1) lovelaceToSendValue)) + >>= signAndSubmitConfirmed_ From 02a199d46244bece06a6ca2273ed37c9efe0ba12 Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Mon, 15 Jul 2024 22:27:38 -0600 Subject: [PATCH 06/15] Use common `addRefScript` --- atlas-cardano.cabal | 1 + src/GeniusYield/Examples/Limbo.hs | 58 ---------------- src/GeniusYield/Test/Privnet/Ctx.hs | 46 ------------- .../Test/Privnet/Examples/Common.hs | 9 +++ src/GeniusYield/Test/Privnet/Examples/Gift.hs | 66 ++++++------------- src/GeniusYield/Test/Privnet/Examples/Misc.hs | 14 ++-- 6 files changed, 35 insertions(+), 159 deletions(-) create mode 100644 src/GeniusYield/Test/Privnet/Examples/Common.hs diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index ccc0a077..1b51d433 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -90,6 +90,7 @@ library GeniusYield.Test.Privnet.Asserts GeniusYield.Test.Privnet.Ctx GeniusYield.Test.Privnet.Examples + GeniusYield.Test.Privnet.Examples.Common GeniusYield.Test.Privnet.Examples.Gift GeniusYield.Test.Privnet.Examples.Misc GeniusYield.Test.Privnet.Examples.Oracle diff --git a/src/GeniusYield/Examples/Limbo.hs b/src/GeniusYield/Examples/Limbo.hs index 47710d4d..48917b60 100644 --- a/src/GeniusYield/Examples/Limbo.hs +++ b/src/GeniusYield/Examples/Limbo.hs @@ -8,21 +8,12 @@ Stability : develop -} module GeniusYield.Examples.Limbo ( - -- * Scripts limboValidatorV1, limboValidatorV2, - -- * API - getRefInfos, - addRefScript, - addRefScript', - findRefScriptsInBody, ) where -import GeniusYield.Imports -import GeniusYield.TxBuilder.Class import GeniusYield.Types -import qualified Data.Map.Strict as Map import GeniusYield.Examples.Common (toDeBruijn) import qualified PlutusCore.Version as PLC import qualified PlutusLedgerApi.Common as Plutus @@ -58,52 +49,3 @@ limboValidatorV2 = validatorFromSerialisedScript limboValidatorPlutusSerialised limboValidatorPlutusSerialised :: Plutus.SerialisedScript limboValidatorPlutusSerialised = Plutus.serialiseUPLC $ UPLC.Program () PLC.plcVersion100 limboScript' - -------------------------------------------------------------------------------- --- API -------------------------------------------------------------------------------- - -utxoToRefMap :: GYUTxOs -> Map (Some GYScript) GYTxOutRef -utxoToRefMap utxo = Map.fromList - [ (sc, ref) - | GYUTxO { utxoRef = ref, utxoRefScript = Just sc} <- utxosToList utxo - ] - --- | Find reference scripts at 'limboValidatorV2' address. --- -getRefInfos :: GYTxQueryMonad m => m (Map (Some GYScript) GYTxOutRef) -getRefInfos = do - addr <- scriptAddress limboValidatorV2 - utxo <- utxosAtAddress addr Nothing - return $ utxoToRefMap utxo - --- | Create UTxO with a reference script. --- --- This is optimized version. --- First it checks whether there is an UTxO already with a script. --- Only if there aren't the new transaction skeleton is constructed. --- -addRefScript :: GYTxQueryMonad m => GYScript 'PlutusV2 -> m (Either GYTxOutRef (GYTxSkeleton v)) -addRefScript sc = do - addr <- scriptAddress limboValidatorV2 - utxo <- utxosAtAddress addr Nothing - - let refs :: Map (Some GYScript) GYTxOutRef - refs = utxoToRefMap utxo - - case Map.lookup (Some sc) refs of - Just ref -> return $ Left ref - Nothing -> return $ Right $ mustHaveOutput (mkGYTxOut addr mempty (datumFromPlutusData ())) { gyTxOutRefS = Just $ GYPlutusScript sc } - --- | Create UTxO with a reference script. --- -addRefScript' :: GYTxQueryMonad m => GYScript 'PlutusV2 -> m (GYTxSkeleton v) -addRefScript' sc = do - addr <- scriptAddress limboValidatorV2 - return $ mustHaveOutput (mkGYTxOut addr mempty (datumFromPlutusData ())) { gyTxOutRefS = Just $ GYPlutusScript sc } - --- | Find reference scripts in transaction body. -findRefScriptsInBody :: GYTxBody -> Map (Some GYScript) GYTxOutRef -findRefScriptsInBody body = do - let utxo = txBodyUTxOs body - utxoToRefMap utxo diff --git a/src/GeniusYield/Test/Privnet/Ctx.hs b/src/GeniusYield/Test/Privnet/Ctx.hs index a93c95e9..afb91d2b 100644 --- a/src/GeniusYield/Test/Privnet/Ctx.hs +++ b/src/GeniusYield/Test/Privnet/Ctx.hs @@ -34,16 +34,10 @@ module GeniusYield.Test.Privnet.Ctx ( newTempUserCtx, ctxQueryBalance, findOutput, - addRefScriptCtx, - addRefInputCtx, ) where import qualified Cardano.Api as Api import Data.Default (Default (..)) -import qualified Data.Map.Strict as Map - -import qualified GeniusYield.Examples.Limbo as Limbo -import GeniusYield.HTTP.Errors (someBackendError) import GeniusYield.Imports import GeniusYield.Providers.Node import GeniusYield.TxBuilder @@ -182,43 +176,3 @@ findOutput addr txBody = do let utxos = txBodyUTxOs txBody maybe (assertFailure "expecting an order in utxos") return $ findFirst (\utxo -> if utxoAddress utxo == addr then Just (utxoRef utxo) else Nothing) $ utxosToList utxos - --- | Function to add for a reference script. It adds the script in so called "Always failing" validator so that it won't be later possible to spend this output. There is a slight optimisation here in that if the desired reference script already exists then we don't add another one and return the reference for the found one else, we create a new one. -addRefScriptCtx :: Ctx -- ^ Given context. - -> User -- ^ User which will execute the transaction (if required). - -> GYScript 'PlutusV2 -- ^ Given script. - -> IO GYTxOutRef -- ^ Returns the reference for the desired output. -addRefScriptCtx ctx user script = ctxRun ctx user $ do - txBodyRefScript <- Limbo.addRefScript script >>= traverse buildTxBody - case txBodyRefScript of - Left ref -> pure ref - Right body -> do - let refs = Limbo.findRefScriptsInBody body - ref <- case Map.lookup (Some script) refs of - Just ref -> return ref - Nothing -> throwAppError $ someBackendError "Shouldn't happen: no ref in body" - signAndSubmitConfirmed_ body - pure ref - --- | Function to add for a reference input. -addRefInputCtx :: Ctx -- ^ Given context. - -> User -- ^ User which will execute this transaction. - -> Bool -- ^ Whether to inline the datum. - -> GYAddress -- ^ Address to put this output at. - -> GYDatum -- ^ The datum to put. - -> IO GYTxOutRef -- ^ Returns the reference for the required output. -addRefInputCtx ctx user toInline addr ourDatum = ctxRun ctx user $ do - txBody <- buildTxBody $ mustHaveOutput (GYTxOut addr mempty (Just (ourDatum, if toInline then GYTxOutUseInlineDatum else GYTxOutDontUseInlineDatum)) Nothing) - let utxos = utxosToList $ txBodyUTxOs txBody - ourDatumHash = hashDatum ourDatum - mRefInputUtxo = find (\utxo -> - case utxoOutDatum utxo of - GYOutDatumHash dh -> ourDatumHash == dh - GYOutDatumInline d -> ourDatum == d - GYOutDatumNone -> False - ) utxos - case mRefInputUtxo of - Nothing -> throwAppError $ someBackendError "Shouldn't happen: Couldn't find desired UTxO in tx outputs" - Just GYUTxO {utxoRef} -> do - signAndSubmitConfirmed_ txBody - pure utxoRef diff --git a/src/GeniusYield/Test/Privnet/Examples/Common.hs b/src/GeniusYield/Test/Privnet/Examples/Common.hs new file mode 100644 index 00000000..f53b572c --- /dev/null +++ b/src/GeniusYield/Test/Privnet/Examples/Common.hs @@ -0,0 +1,9 @@ +module GeniusYield.Test.Privnet.Examples.Common (addRefScriptToLimbo) where + +import GeniusYield.Examples.Limbo +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder +import GeniusYield.Types + +addRefScriptToLimbo :: GYScript PlutusV2 -> 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 c37274e1..21961625 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Gift.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Gift.hs @@ -10,32 +10,30 @@ Stability : develop {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} -module GeniusYield.Test.Privnet.Examples.Gift (tests, resolveRefScript, resolveRefScript') where - -import qualified Cardano.Api as Api -import qualified Cardano.Api.Shelley as Api.S -import Control.Applicative ((<|>)) -import Control.Concurrent (threadDelay) -import Control.Lens ((.~)) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCaseSteps) - -import qualified Data.Map.Strict as Map -import Data.Maybe (fromJust) -import Data.Ratio ((%)) -import qualified Data.Set as Set +module GeniusYield.Test.Privnet.Examples.Gift (tests) where + +import qualified Cardano.Api as Api +import qualified Cardano.Api.Shelley as Api.S +import Control.Applicative ((<|>)) +import Control.Concurrent (threadDelay) +import Control.Lens ((.~)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCaseSteps) + +import Data.Maybe (fromJust) +import Data.Ratio ((%)) +import qualified Data.Set as Set import GeniusYield.Imports import GeniusYield.Transaction import GeniusYield.Types -import Data.Default (Default (def)) +import Data.Default (Default (def)) import GeniusYield.Examples.Gift -import GeniusYield.Examples.Limbo import GeniusYield.Examples.Treat -import GeniusYield.HTTP.Errors (someBackendError) -import GeniusYield.Providers.Common (SubmitTxException) +import GeniusYield.Providers.Common (SubmitTxException) import GeniusYield.Test.Privnet.Asserts import GeniusYield.Test.Privnet.Ctx +import GeniusYield.Test.Privnet.Examples.Common import GeniusYield.Test.Privnet.Setup import GeniusYield.TxBuilder @@ -284,9 +282,7 @@ tests setup = testGroup "gift" , testCaseSteps "Matching Reference Script from UTxO" $ \info -> withSetup info setup $ \ctx -> do giftCleanup ctx - ref <- ctxRun ctx (ctxUserF ctx) $ do - txBodyRefScript <- addRefScript' (validatorToScript giftValidatorV2) >>= buildTxBody - resolveRefScript' txBodyRefScript (Some (validatorToScript giftValidatorV2)) + ref <- ctxRun ctx (ctxUserF ctx) . addRefScriptToLimbo $ validatorToScript giftValidatorV2 info $ "Reference at " ++ show ref @@ -311,9 +307,7 @@ tests setup = testGroup "gift" -- this creates utxo which looks like -- -- 3c6ad9c5c512c06add1cd6bb513f1e879d5cadbe70f4762d4ff810d37ab9e0c0 1 1081810 lovelace + TxOutDatumHash ScriptDataInBabbageEra "923918e403bf43c34b4ef6b48eb2ee04babed17320d8d1b9ff9ad086e86f44ec" - ref <- ctxRun ctx (ctxUserF ctx) $ do - txBodyRefScript <- addRefScript (validatorToScript giftValidatorV2) >>= traverse buildTxBody - resolveRefScript txBodyRefScript (Some (validatorToScript giftValidatorV2)) + ref <- ctxRun ctx (ctxUserF ctx) . addRefScriptToLimbo $ validatorToScript giftValidatorV2 info $ "Reference at " ++ show ref @@ -362,9 +356,7 @@ tests setup = testGroup "gift" -- this creates utxo which looks like -- -- 3c6ad9c5c512c06add1cd6bb513f1e879d5cadbe70f4762d4ff810d37ab9e0c0 1 1081810 lovelace + TxOutDatumHash ScriptDataInBabbageEra "923918e403bf43c34b4ef6b48eb2ee04babed17320d8d1b9ff9ad086e86f44ec" - ref <- ctxRun ctx (ctxUserF ctx) $ do - txBodyRefScript <- addRefScript (validatorToScript giftValidatorV2) >>= traverse buildTxBody - resolveRefScript txBodyRefScript (Some (validatorToScript giftValidatorV2)) + ref <- ctxRun ctx (ctxUserF ctx) . addRefScriptToLimbo $ validatorToScript giftValidatorV2 info $ "Reference at " ++ show ref @@ -414,9 +406,7 @@ tests setup = testGroup "gift" -- this creates utxo which looks like -- -- 3c6ad9c5c512c06add1cd6bb513f1e879d5cadbe70f4762d4ff810d37ab9e0c0 1 1081810 lovelace + TxOutDatumHash ScriptDataInBabbageEra "923918e403bf43c34b4ef6b48eb2ee04babed17320d8d1b9ff9ad086e86f44ec" - ref <- ctxRun ctx (ctxUserF ctx) $ do - txBodyRefScript <- addRefScript (validatorToScript giftValidatorV2) >>= traverse buildTxBody - resolveRefScript txBodyRefScript (Some (validatorToScript giftValidatorV2)) + ref <- ctxRun ctx (ctxUserF ctx) . addRefScriptToLimbo $ validatorToScript giftValidatorV2 info $ "Reference at " ++ show ref @@ -656,19 +646,3 @@ checkCollateral inputValue returnValue totalCollateralLovelace txFee collPer = && balanceLovelace>= ceiling (txFee * collPer % 100) -- Api checks via `balanceLovelace * 100 >= txFee * collPer` which IMO works as `balanceLovelace` is an integer & 100 but in general `c >= ceil (a / b)` is not equivalent to `c * b >= a`. && inputValue == returnValue <> valueFromLovelace totalCollateralLovelace where (balanceLovelace, balanceOther) = valueSplitAda $ inputValue `valueMinus` returnValue - -resolveRefScript :: Either GYTxOutRef GYTxBody -> Some GYScript -> GYTxMonadIO GYTxOutRef -resolveRefScript txBodyRefScript script = - case txBodyRefScript of - Left ref -> pure ref - Right body -> resolveRefScript' body script - -resolveRefScript' :: GYTxBody -> Some GYScript -> GYTxMonadIO GYTxOutRef -resolveRefScript' txBodyRefScript script = do - let refs = findRefScriptsInBody txBodyRefScript - ref <- case Map.lookup script refs of - Just ref -> return ref - Nothing -> throwAppError $ someBackendError "Shouldn't happen: no ref in body" - - void $ signAndSubmitConfirmed_ txBodyRefScript - return ref diff --git a/src/GeniusYield/Test/Privnet/Examples/Misc.hs b/src/GeniusYield/Test/Privnet/Examples/Misc.hs index 44ea9b80..38ce8ae9 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Misc.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Misc.hs @@ -9,18 +9,16 @@ Stability : develop module GeniusYield.Test.Privnet.Examples.Misc (tests) where -import Control.Concurrent (threadDelay) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCaseSteps) +import Control.Concurrent (threadDelay) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCaseSteps) -import GeniusYield.Imports import GeniusYield.Scripts.TestToken import GeniusYield.Types -import GeniusYield.Examples.Limbo (addRefScript) import GeniusYield.Test.Privnet.Asserts import GeniusYield.Test.Privnet.Ctx -import GeniusYield.Test.Privnet.Examples.Gift (resolveRefScript) +import GeniusYield.Test.Privnet.Examples.Common import GeniusYield.Test.Privnet.Setup import GeniusYield.TxBuilder @@ -35,9 +33,7 @@ tests setup = testGroup "misc" policyAsScript = mintingPolicyToScript policy ac = GYToken (mintingPolicyId policy) tn - refScript <- ctxRun ctx (ctxUserF ctx) $ do - txBodyRefScript <- addRefScript policyAsScript >>= traverse buildTxBody - resolveRefScript txBodyRefScript (Some policyAsScript) + refScript <- ctxRun ctx (ctxUserF ctx) $ addRefScriptToLimbo policyAsScript -- wait a tiny bit. threadDelay 1_000_000 From e02eaea89f5e812cd0bb756faa953ebb41fddcba Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Wed, 17 Jul 2024 11:32:04 -0600 Subject: [PATCH 07/15] Make `withWalletBalancesCheck` usable to `GYTxQueryMonad` --- src/GeniusYield/Test/Utils.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index 0c84b32a..3cd324ca 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -31,6 +31,7 @@ import Control.Lens ((^.)) import Control.Monad.Random import Data.List (findIndex) import qualified Data.Map.Strict as Map +import qualified Data.Text as T import qualified Data.Sequence.Strict as StrictSeq import Prettyprinter (PageWidth (AvailablePerLine), @@ -187,10 +188,10 @@ data Wallets = Wallets , w9 :: !User } deriving (Show, Eq, Ord) -{- | Computes a `GYTxMonadClb` action and returns the result and how this action +{- | Computes a `GYTx*Monad` action and returns the result and how this action changed the balance of some "Address". -} -withBalance :: String -> User -> GYTxMonadClb b -> GYTxMonadClb (b, GYValue) +withBalance :: GYTxQueryMonad m => String -> User -> m b -> m (b, GYValue) withBalance n a m = do old <- queryBalance $ userAddr a b <- m @@ -199,18 +200,18 @@ withBalance n a m = do gyLogDebug' "" $ printf "%s:\nold balance: %s\nnew balance: %s\ndiff: %s" n old new diff return (b, diff) -{- | Computes a 'GYTxMonadClb' action, checking that the 'Wallet' balances +{- | Computes a `GYTx*Monad` action, checking that the 'Wallet' balances change according to the input list. Notes: * An empty list means no checks are performed. * The 'GYValue' should be negative to check if the Wallet lost those funds. -} -withWalletBalancesCheck :: [(User, GYValue)] -> GYTxMonadClb a -> GYTxMonadClb a +withWalletBalancesCheck :: GYTxQueryMonad m => [(User, GYValue)] -> m a -> m a withWalletBalancesCheck [] m = m withWalletBalancesCheck ((w, v) : xs) m = do (b, diff) <- withBalance (show $ userAddr w) w $ withWalletBalancesCheck xs m unless (diff == v) $ do - fail $ printf "expected balance difference of %s for wallet %s, but the actual difference was %s" v (userAddr w) diff + throwAppError . someBackendError . T.pack $ printf "expected balance difference of %s for wallet %s, but the actual difference was %s" v (userAddr w) diff return b {- | Returns the list of outputs of the transaction for the given address. @@ -249,6 +250,7 @@ findRefScriptsInBody body = do utxoToRefMap utxo -- | Adds the given script to the given address and returns the reference for it. +-- Note: The new utxo is given an inline unit datum. addRefScript :: forall m. GYTxMonad m => GYAddress -> GYScript 'PlutusV2 -> m GYTxOutRef addRefScript addr sc = throwAppError absurdError `runEagerT` do existingUtxos <- lift $ utxosAtAddress addr Nothing From 4a254570e98327f5b26494b82961287e6a7d0d4d Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Wed, 17 Jul 2024 11:32:17 -0600 Subject: [PATCH 08/15] Export `ftLift` and `ftgLift` --- src/GeniusYield/Test/FeeTracker.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/GeniusYield/Test/FeeTracker.hs b/src/GeniusYield/Test/FeeTracker.hs index ef2f6b28..a2cf4218 100644 --- a/src/GeniusYield/Test/FeeTracker.hs +++ b/src/GeniusYield/Test/FeeTracker.hs @@ -10,6 +10,8 @@ Stability : develop module GeniusYield.Test.FeeTracker ( FeeTrackerGame, FeeTracker, + ftgLift, + ftLift, withWalletBalancesCheckSimple, withWalletBalancesCheckSimpleIgnoreMinDepFor ) where @@ -78,6 +80,7 @@ deriving via StateT FeeTrackerState m instance MonadError GYTxMonadException m => MonadError GYTxMonadException (FeeTracker m) +-- | Perform a special action supported by the specific wrapped monad instance by lifting it to 'FeeTracker'. ftLift :: Functor m => m a -> FeeTracker m a ftLift act = FeeTracker $ \s -> (, s) <$> act @@ -161,6 +164,7 @@ walletExtraLovelace m = M.map (\FeeTrackerState {feesPerTx} -> foldMap snd . fil where validTxIds = S.fromList . concatMap submittedTxIds $ M.elems m +-- | Perform a special action supported by the specific wrapped monad instance by lifting it to 'FeeTrackerGame'. ftgLift :: Functor m => m a -> FeeTrackerGame m a ftgLift act = FeeTrackerGame $ \s -> (, s) <$> act From 9812f726619bacead962ac282ddda346a7fba1c8 Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Wed, 17 Jul 2024 11:32:48 -0600 Subject: [PATCH 09/15] Add `void`ed wait slot utilities --- src/GeniusYield/TxBuilder/Class.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/GeniusYield/TxBuilder/Class.hs b/src/GeniusYield/TxBuilder/Class.hs index c06743ac..fa85dbea 100644 --- a/src/GeniusYield/TxBuilder/Class.hs +++ b/src/GeniusYield/TxBuilder/Class.hs @@ -23,6 +23,8 @@ module GeniusYield.TxBuilder.Class , buildTxBodyParallel , buildTxBodyChaining , waitNSlots + , waitNSlots_ + , waitUntilSlot_ , submitTx_ , submitTxConfirmed , submitTxConfirmed_ @@ -267,6 +269,10 @@ Just one type inference (or signature) on the top most call that runs the 'GYTxG will be automatically inferred. -} +-- | > waitUntilSlot_ = void . waitUntilSlot +waitUntilSlot_ :: GYTxGameMonad m => GYSlot -> m () +waitUntilSlot_ = void . waitUntilSlot + -- | Wait until the chain tip has progressed by N slots. waitNSlots :: GYTxGameMonad m => Word64 -> m GYSlot waitNSlots (slotFromWord64 -> n) = do @@ -276,6 +282,10 @@ waitNSlots (slotFromWord64 -> n) = do where addSlots = (+) `on` slotToApi +-- | > waitNSlots_ = void . waitNSlots +waitNSlots_ :: GYTxGameMonad m => Word64 -> m () +waitNSlots_ = void . waitNSlots + -- | > submitTx_ = void . submitTx submitTx_ :: GYTxMonad m => GYTx -> m () submitTx_ = void . submitTx From 50fcf259ab65845e9124511009bb7a187c1f9964 Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Wed, 17 Jul 2024 11:42:04 -0600 Subject: [PATCH 10/15] Add bet-ref test suite --- atlas-cardano.cabal | 28 +++ .../Test/Unified/BetRef/Operations.hs | 97 ++++++++ .../Test/Unified/BetRef/PlaceBet.hs | 227 ++++++++++++++++++ .../Test/Unified/BetRef/TakePot.hs | 85 +++++++ .../Test/Unified/OnChain/BetRef.hs | 148 ++++++++++++ .../Test/Unified/OnChain/BetRef/Compiled.hs | 26 ++ tests-unified/atlas-unified-tests.hs | 11 + 7 files changed, 622 insertions(+) create mode 100644 tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs create mode 100644 tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs create mode 100644 tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs create mode 100644 tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs create mode 100644 tests-unified/GeniusYield/Test/Unified/OnChain/BetRef/Compiled.hs create mode 100644 tests-unified/atlas-unified-tests.hs diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index 1b51d433..8922cf25 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -353,3 +353,31 @@ test-suite atlas-privnet-tests , tasty , tasty-hunit +test-suite atlas-unified-tests + import: common, plutus-ghc-options + type: exitcode-stdio-1.0 + main-is: atlas-unified-tests.hs + hs-source-dirs: tests-unified + ghc-options: -threaded -rtsopts -Wall + + -- set target plutus-core version + ghc-options: -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 + other-modules: + GeniusYield.Test.Unified.OnChain.BetRef + GeniusYield.Test.Unified.OnChain.BetRef.Compiled + GeniusYield.Test.Unified.BetRef.Operations + GeniusYield.Test.Unified.BetRef.PlaceBet + GeniusYield.Test.Unified.BetRef.TakePot + -- Dependencies inherited from the library. No need to specify bounds. + build-depends: + , atlas-cardano + , base + , containers + , tasty + , tasty-hunit + , mtl + -- OnChain + , plutus-core + , plutus-ledger-api + , plutus-tx + , plutus-tx-plugin diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs new file mode 100644 index 00000000..bc8761f1 --- /dev/null +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs @@ -0,0 +1,97 @@ +module GeniusYield.Test.Unified.BetRef.Operations + ( betRefValidator' + , betRefAddress + , placeBet + , takeBets + ) where + +import GeniusYield.Imports +import GeniusYield.TxBuilder +import GeniusYield.Types + +import GeniusYield.Test.Unified.OnChain.BetRef.Compiled + +-- | Validator in question, obtained after giving required parameters. +betRefValidator' :: BetRefParams -> GYValidator 'PlutusV2 +betRefValidator' brp = validatorFromPlutus $ betRefValidator brp + +-- | Address of the validator, given params. +betRefAddress :: (HasCallStack, GYTxQueryMonad m) => BetRefParams -> m GYAddress +betRefAddress brp = scriptAddress $ betRefValidator' brp + +-- | Operation to place bet. +placeBet :: (HasCallStack, GYTxMonad m) + => GYTxOutRef -- ^ Reference Script. + -> BetRefParams -- ^ Validator Params. + -> OracleAnswerDatum -- ^ Guess. + -> GYValue -- ^ Bet amount to place. + -> GYAddress -- ^ Own address. + -> Maybe GYTxOutRef -- ^ Reference to previous bets UTxO (if any). + -> m (GYTxSkeleton 'PlutusV2) +placeBet refScript brp guess bet ownAddr mPreviousBetsUtxoRef = do + gyLogDebug' "" $ printf "ownAddr: %s" (show ownAddr) + gyLogDebug' "" $ printf "refOut: %s" (show mPreviousBetsUtxoRef) + + pkh <- addressToPubKeyHash' ownAddr + betAddr <- betRefAddress brp + case mPreviousBetsUtxoRef of + -- This is the first bet. + Nothing -> do + return $ mustHaveOutput $ GYTxOut + { gyTxOutAddress = betAddr + , gyTxOutValue = bet + , gyTxOutDatum = Just (datumFromPlutusData $ BetRefDatum [(pubKeyHashToPlutus pkh, guess)] (valueToPlutus bet), GYTxOutDontUseInlineDatum) + , gyTxOutRefS = Nothing + } + -- Need to append to previous. + Just previousBetsUtxoRef -> do + previousUtxo <- utxoAtTxOutRef' previousBetsUtxoRef + gyLogDebug' "" $ printf "1. previousUtxo: %s" (show previousUtxo) + (_addr, previousValue, dat@(BetRefDatum previousGuesses _previousBet)) <- utxoDatum' previousUtxo + gyLogDebug' "" $ printf "2. previous guesses %s" (show previousGuesses) + betUntilSlot <- enclosingSlotFromTime' (timeFromPlutus $ brpBetUntil brp) + gyLogDebug' "" $ printf "3. bet until slot %s" (show betUntilSlot) + return $ + input brp refScript previousBetsUtxoRef dat (Bet guess) + <> mustHaveOutput GYTxOut + { gyTxOutAddress = betAddr + , gyTxOutValue = bet <> previousValue + , gyTxOutDatum = Just + ( datumFromPlutusData $ BetRefDatum ((pubKeyHashToPlutus pkh, guess) : previousGuesses) (valueToPlutus bet) + , GYTxOutDontUseInlineDatum + ) + , gyTxOutRefS = Nothing + } + <> isInvalidAfter betUntilSlot + <> mustBeSignedBy pkh + +-- | Operation to take UTxO corresponding to previous bets. +takeBets :: (HasCallStack, GYTxMonad m) + => GYTxOutRef -- ^ Reference Script. + -> BetRefParams -- ^ Validator params. + -> GYTxOutRef -- ^ Script UTxO to consume. + -> GYAddress -- ^ Own address. + -> GYTxOutRef -- ^ Oracle reference input. + -> m (GYTxSkeleton 'PlutusV2) +takeBets refScript brp previousBetsUtxoRef ownAddr oracleRefInput = do + pkh <- addressToPubKeyHash' ownAddr + previousUtxo <- utxoAtTxOutRef' previousBetsUtxoRef + (_addr, _previousValue, dat) <- utxoDatum' previousUtxo + betRevealSlot <- enclosingSlotFromTime' (timeFromPlutus $ brpBetReveal brp) + return $ + input brp refScript previousBetsUtxoRef dat Take + <> isInvalidBefore betRevealSlot + <> mustHaveRefInput oracleRefInput + <> mustBeSignedBy pkh + +-- | Utility function to consume script UTxO. +input :: BetRefParams -> GYTxOutRef -> GYTxOutRef -> BetRefDatum -> BetRefAction -> GYTxSkeleton 'PlutusV2 +input brp refScript inputRef dat red = + mustHaveInput GYTxIn + { gyTxInTxOutRef = inputRef + -- , gyTxInWitness = GYTxInWitnessKey + , gyTxInWitness = GYTxInWitnessScript + (GYInReference refScript $ validatorToScript $ betRefValidator' brp) + (datumFromPlutusData dat) + (redeemerFromPlutusData red) + } diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs new file mode 100644 index 00000000..2e71c305 --- /dev/null +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -0,0 +1,227 @@ +module GeniusYield.Test.Unified.BetRef.PlaceBet + ( placeBetTests + , computeParamsAndAddRefScript + , multipleBetsTraceCore + ) where + +import qualified Data.Set as Set +import Test.Tasty (TestTree, testGroup) + + +import GeniusYield.Test.Unified.BetRef.Operations +import GeniusYield.Test.Unified.OnChain.BetRef.Compiled + +import GeniusYield.Imports +import GeniusYield.Test.Clb +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder +import GeniusYield.Types + +-- | Our unit tests for placing bet operation +placeBetTests :: TestTree +placeBetTests = testGroup "Place Bet" + [ mkTestFor "Simple spending tx" simplSpendingTxTrace + , mkTestFor "Balance checks after placing first bet" $ + firstBetTrace (OracleAnswerDatum 3) (valueFromLovelace 20_000_000) 0_176_545 + , mkTestFor "Balance checks with multiple bets" $ multipleBetsTraceWrapper 400 1_000 (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> fakeGold 1_000) + ] + , mkTestFor "Not adding atleast bet step amount should fail" $ mustFail . multipleBetsTraceWrapper 400 1_000 (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 55_000_000 <> fakeGold 1_000)] + ] + +-- ----------------------------------------------------------------------------- +-- Super-trivial example +-- ----------------------------------------------------------------------------- + +-- | Trace for a super-simple spending transaction. +simplSpendingTxTrace :: Wallets -> GYTxMonadClb () +simplSpendingTxTrace Wallets{w1} = do + gyLogDebug' "" "Hey there!" + -- balance assetion check + void . withWalletBalancesCheck [w1 := valueNegate (valueFromLovelace 100_173_685)] . asUser w1 $ do -- TODO: w1 is the wallets that gets all funds for now + skeleton <- mkTrivialTx + gyLogDebug' "" $ printf "tx skeleton: %s" (show skeleton) + + dumpUtxoState + -- test itself + txId <- buildTxBody skeleton >>= signAndSubmitConfirmed + dumpUtxoState + gyLogDebug' "" $ printf "tx submitted, txId: %s" txId + +-- Pretend off-chain code written in 'GYTxMonad m' +mkTrivialTx :: GYTxMonad m => m (GYTxSkeleton 'PlutusV2) +mkTrivialTx = do + addr <- fmap (!! 0) ownAddresses -- FIXME: + gyLogDebug' "" $ printf "ownAddr: %s" (show addr) + pkh <- addressToPubKeyHash' addr + let targetAddr = unsafeAddressFromText "addr_test1qr2vfntpz92f9pawk8gs0fdmhtfe32pqcx0s8fuztxaw3p5pjay24kygaj4g8uevf89ewxzvsdc60wln8spzm2al059q8a9w3x" + -- let targetAddr = unsafeAddressFromText "addr1q82vfntpz92f9pawk8gs0fdmhtfe32pqcx0s8fuztxaw3p5pjay24kygaj4g8uevf89ewxzvsdc60wln8spzm2al059qytcwae" + return $ + mustHaveOutput + (GYTxOut + { gyTxOutAddress = targetAddr + , gyTxOutValue = valueFromLovelace 100_000_000 + , gyTxOutDatum = Nothing + , gyTxOutRefS = Nothing + }) + <> mustBeSignedBy pkh + +{- + +Test code levels: + +Level 1. Test assertion $ test action (express the test) +Level 2. Runner $ test action (injects wallets) +Level 3. The action (Off-chain code) + +-} + +-- ----------------------------------------------------------------------------- +-- First-bet trace example +-- ----------------------------------------------------------------------------- + +-- | Trace for placing the first bet. +firstBetTrace :: OracleAnswerDatum -- ^ Guess + -> GYValue -- ^ Bet + -> Integer -- ^ Expected fees + -> Wallets -> GYTxMonadClb () -- Our continuation function +firstBetTrace dat bet expectedFees ws@Wallets{w1} = do + + -- First step: Get the required parameters for initializing our parameterized script, + -- claculate the script, and post it to the blockchain as a reference script. + (brp, refScript) <- computeParamsAndAddRefScript 40 100 (valueFromLovelace 200_000_000) ws + void . withWalletBalancesCheck [w1 := valueNegate (valueFromLovelace expectedFees <> bet)] . asUser w1 $ do -- following operations are ran by first wallet, `w1` + -- Second step: Perform the actual run. + placeBetRun refScript brp dat bet Nothing + +-- | Function to compute the parameters for the contract and add the corresponding refernce script. +computeParamsAndAddRefScript + :: Integer -- ^ Bet Until slot + -> Integer -- ^ Bet Reveal slot + -> GYValue -- ^ Bet step value + -> Wallets -> GYTxMonadClb (BetRefParams, GYTxOutRef) -- Our continuation +computeParamsAndAddRefScript betUntil' betReveal' betStep Wallets{..} = do + let betUntil = slotFromApi (fromInteger betUntil') + betReveal = slotFromApi (fromInteger betReveal') + asUser w1 $ do + betUntilTime <- slotToBeginTime betUntil + betRevealTime <- slotToBeginTime betReveal + + let brp = BetRefParams + (pubKeyHashToPlutus $ userPkh w8) -- let oracle be wallet `w8` + (timeToPlutus betUntilTime) + (timeToPlutus betRevealTime) + (valueToPlutus betStep) + + -- let store scripts in `w9` + let w9addr = userAddr w9 + gyLogDebug' "" $ "Wallet 9 addr: " <> show w9addr + refScript <- addRefScript w9addr . validatorToScript $ betRefValidator' brp + gyLogDebug' "" $ printf "reference script output: %s" (show refScript) + pure (brp, refScript) + +-- | Run to call the `placeBet` operation. +placeBetRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> OracleAnswerDatum -> GYValue -> Maybe GYTxOutRef -> m GYTxId +placeBetRun refScript brp guess bet mPreviousBetsUtxoRef = do + addr <- (!! 0) <$> ownAddresses + gyLogDebug' "" $ printf "bet: %s" (show bet) + skeleton <- placeBet refScript brp guess bet addr mPreviousBetsUtxoRef + gyLogDebug' "" $ printf "place bet tx skeleton: %s" (show skeleton) + buildTxBody skeleton >>= signAndSubmitConfirmed + -- txId <- sendSkeleton skeleton + -- dumpUtxoState + -- pure txId + +-- ----------------------------------------------------------------------------- +-- Multiple bets example +-- ----------------------------------------------------------------------------- + +-- | Trace which allows for multiple bets. +multipleBetsTraceWrapper + :: Integer -- ^ slot for betUntil + -> Integer -- ^ slot for betReveal + -> GYValue -- ^ bet step + -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets + -> Wallets -> GYTxMonadClb () -- Our continuation function +multipleBetsTraceWrapper betUntil' betReveal' betStep walletBets ws = do + -- First step: Get the required parameters for initializing our parameterized script and add the corresponding reference script + (brp, refScript) <- computeParamsAndAddRefScript betUntil' betReveal' betStep ws + -- Second step: Perform the actual bet operations + multipleBetsTraceCore brp refScript walletBets ws + +-- | Trace which allows for multiple bets. +multipleBetsTraceCore + :: BetRefParams + -> GYTxOutRef -- ^ Reference script + -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets + -> Wallets -> GYTxMonadClb () -- Our continuation function +multipleBetsTraceCore brp refScript walletBets ws@Wallets{..} = do + let + -- | Perform the actual bet operation by the corresponding wallet. + performBetOperations [] _ = return () + performBetOperations ((getWallet, dat, bet) : remWalletBets) isFirst = do + if isFirst then do + gyLogInfo' "" "placing the first bet" + void $ asUser (getWallet ws) $ do + void $ placeBetRun refScript brp dat bet Nothing + performBetOperations remWalletBets False + else do + gyLogInfo' "" "placing a next bet" + -- need to get previous bet utxo + void $ asUser (getWallet ws) $ do + betRefAddr <- betRefAddress brp + [_scriptUtxo@GYUTxO {utxoRef}] <- utxosToList <$> utxosAtAddress betRefAddr Nothing + gyLogDebug' "" $ printf "previous bet utxo: %s" utxoRef + void $ placeBetRun refScript brp dat bet (Just utxoRef) + performBetOperations remWalletBets False + + -- | To sum the bet amount for the corresponding wallet. + sumWalletBets _wallet [] acc = acc + sumWalletBets wallet ((getWallet, _dat, bet) : remWalletBets) acc = sumWalletBets wallet remWalletBets (if getWallet ws == wallet then acc <> valueNegate bet else acc) + -- | Idea here is that for each wallet, we want to know how much has been bet. If we encounter a new wallet, i.e., wallet for whose we haven't yet computed value lost, we call `sumWalletBets` on it. + + getBalanceDiff [] _set acc = acc + getBalanceDiff wlBets@((getWallet, _dat, _bet) : remWalletBets) set acc = + let wallet = getWallet ws + wallet'sAddr = userAddr wallet + in + if Set.member wallet'sAddr set then getBalanceDiff remWalletBets set acc + else + getBalanceDiff remWalletBets (Set.insert wallet'sAddr set) ((wallet := sumWalletBets wallet wlBets mempty) : acc) + + balanceDiffWithoutFees = getBalanceDiff walletBets Set.empty [] + + -- The test itself + balanceBeforeAllTheseOps <- asUser w1 $ traverse (\(wallet, _value) -> queryBalances $ userAddresses' wallet) balanceDiffWithoutFees + gyLogDebug' "" $ printf "balanceBeforeAllTheseOps: %s" (mconcat balanceBeforeAllTheseOps) + performBetOperations walletBets True + balanceAfterAllTheseOps <- asUser w1 $ traverse (\(wallet, _value) -> queryBalances $ userAddresses' wallet) balanceDiffWithoutFees + gyLogDebug' "" $ printf "balanceAfterAllTheseOps: %s" (mconcat balanceAfterAllTheseOps) + -- Check the difference + void $ asUser w1 $ verify (zip3 balanceDiffWithoutFees balanceBeforeAllTheseOps balanceAfterAllTheseOps) + where + -- | Function to verify that the wallet indeed lost by /roughly/ the bet amount. + -- We say /roughly/ as fees is assumed to be within (0, 1 ada]. + verify [] = return () + verify (((wallet, diff), vBefore, vAfter) : xs) = + let vAfterWithoutFees = vBefore <> diff + (expectedAdaWithoutFees, expectedOtherAssets) = valueSplitAda vAfterWithoutFees + (actualAda, actualOtherAssets) = valueSplitAda vAfter + threshold = 1_000_000 -- 1 ada + in + if expectedOtherAssets == actualOtherAssets + && actualAda < expectedAdaWithoutFees + && expectedAdaWithoutFees - threshold <= actualAda + then verify xs + else + fail ("For wallet " <> show (userAddr wallet) <> " expected value (without fees) " <> + show vAfterWithoutFees <> " but actual is " <> show vAfter) \ No newline at end of file diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs new file mode 100644 index 00000000..b98bd428 --- /dev/null +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -0,0 +1,85 @@ +module GeniusYield.Test.Unified.BetRef.TakePot + ( takeBetPotTests + ) where + +import Test.Tasty (TestTree, testGroup) + +import GeniusYield.Test.Unified.BetRef.Operations +import GeniusYield.Test.Unified.OnChain.BetRef.Compiled +import GeniusYield.Test.Unified.BetRef.PlaceBet + +import GeniusYield.Imports +import GeniusYield.Test.Clb +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder +import GeniusYield.Types + +-- | Our unit tests for taking the bet pot operation +takeBetPotTests :: TestTree +takeBetPotTests = testGroup "Take bet pot" + [ mkTestFor "Balance check after taking bet pot" $ takeBetsTrace 400 1_000 + (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> fakeGold 1_000) + ] + 4 w2 (Just 0_327_625) + , mkTestFor "Must fail if attempt to take is by wrong guesser" $ mustFail . takeBetsTrace + 400 1_000 (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> fakeGold 1_000) + ] + 5 w2 Nothing + , mkTestFor "Must fail even if old guess was closest but updated one is not" $ + mustFail . takeBetsTrace 400 1_000 (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> fakeGold 1_000) + ] + 2 w2 Nothing + ] + +-- | Run to call the `takeBets` operation. +takeBetsRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> GYTxOutRef -> GYTxOutRef -> m GYTxId +takeBetsRun refScript brp toConsume refInput = do + addr <- fmap (!! 0) ownAddresses -- FIXME: + skeleton <- takeBets refScript brp toConsume addr refInput + buildTxBody skeleton >>= signAndSubmitConfirmed + +-- | Trace for taking bet pot. +takeBetsTrace :: Integer -- ^ slot for betUntil + -> Integer -- ^ slot for betReveal + -> GYValue -- ^ bet step + -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets + -> Integer -- ^ Actual answer + -> (Wallets -> User) -- ^ Taker + -> Maybe Integer -- ^ Expected fees + -> Wallets -> GYTxMonadClb () -- Our continuation function +takeBetsTrace betUntil' betReveal' betStep walletBets answer getTaker mExpectedFees ws@Wallets{..} = do + (brp, refScript) <- computeParamsAndAddRefScript betUntil' betReveal' betStep ws + multipleBetsTraceCore brp refScript walletBets ws + -- Now lets take the bet + ref <- asUser w1 $ addRefInput True (userAddr w8) (datumFromPlutusData $ OracleAnswerDatum answer) + let taker = getTaker ws + case ref of + Just refInput -> do + void $ asUser taker $ do + betRefAddr <- betRefAddress brp + [_scriptUtxo@GYUTxO {utxoRef, utxoValue}] <- utxosToList <$> utxosAtAddress betRefAddr Nothing + gyLogInfo' "" "Slot await complete" + waitUntilSlot_ $ slotFromApi (fromInteger betReveal') + gyLogInfo' "" "Slot await complete" + case mExpectedFees of + Just expectedFees -> do + withWalletBalancesCheck [taker := utxoValue <> valueNegate (valueFromLovelace expectedFees)] $ do + gyLogDebug' "" (show utxoValue) + takeBetsRun refScript brp utxoRef refInput + Nothing -> takeBetsRun refScript brp utxoRef refInput + _ -> fail "Couldn't place reference input successfully" \ No newline at end of file diff --git a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs new file mode 100644 index 00000000..b4ef5e93 --- /dev/null +++ b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module GeniusYield.Test.Unified.OnChain.BetRef + ( mkBetRefValidator + , OracleAnswerDatum (..) + , BetRefParams (..) + , BetRefDatum (..) + , BetRefAction (..) + ) where + +import PlutusLedgerApi.V1.Address (toPubKeyHash) +import PlutusLedgerApi.V1.Interval (contains) +import PlutusLedgerApi.V1.Value (geq) +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V2.Contexts (getContinuingOutputs, findOwnInput, findDatum) +import qualified PlutusTx +import PlutusTx.Prelude as PlutusTx +import Prelude (Show) + +-- | Goals made my the concerned team. +type TeamGoals = Integer + +-- | Match result given by the oracle. +newtype OracleAnswerDatum = OracleAnswerDatum TeamGoals deriving newtype (Eq, Show) +PlutusTx.unstableMakeIsData ''OracleAnswerDatum + +-- | Our contract is parameterized with this. +data BetRefParams = BetRefParams + { brpOraclePkh :: PubKeyHash -- ^ Oracle's payment public key hash. This is needed to assert that UTxO being looked at indeed belongs to the Oracle. + , brpBetUntil :: POSIXTime -- ^ Time until which bets can be placed. + , brpBetReveal :: POSIXTime -- ^ Time at which Oracle will reveal the correct match result. + , brpBetStep :: Value -- ^ Each newly placed bet must be more than previous bet by `brpBetStep` amount. + } +-- PlutusTx.makeLift ''BetRefParams +PlutusTx.unstableMakeIsData ''BetRefParams + +-- | List of guesses by users along with the maximum bet placed yet. A new guess gets /prepended/ to this list. Note that since we are always meant to increment previously placed bet with `brpBetStep`, the newly placed bet would necessarily be maximum (it would be foolish to initialize `brpBetStep` with some negative amounts). +data BetRefDatum = BetRefDatum + { brdBets :: [(PubKeyHash, OracleAnswerDatum)] + , brdPreviousBet :: Value + } +PlutusTx.unstableMakeIsData ''BetRefDatum + +-- | Redeemer representing choices available to the user. +data BetRefAction = Bet !OracleAnswerDatum -- ^ User makes a guess. + | Take -- ^ User takes the pot. +PlutusTx.unstableMakeIsData ''BetRefAction + +-- Note: The first argument is meant to be data encoded 'BetRefParams'. +-- Unable to use the actual type since makeLift doesn't work on it, for whatever reason.... +{-# INLINABLE mkBetRefValidator #-} +-- | Untyped wrapper around `mkBetRefValidator'`. +mkBetRefValidator :: BuiltinData -> BuiltinData -> BuiltinData -> BuiltinData -> () +mkBetRefValidator params dat' red' ctx' + | mkBetRefValidator' (unsafeFromBuiltinData params) (unsafeFromBuiltinData dat') (unsafeFromBuiltinData red') (unsafeFromBuiltinData ctx') = () + | otherwise = error () + +{-# INLINABLE mkBetRefValidator' #-} +-- | Core smart contract logic. Read its description from Atlas guide. +mkBetRefValidator' :: BetRefParams -> BetRefDatum -> BetRefAction -> ScriptContext -> Bool +mkBetRefValidator' (BetRefParams oraclePkh betUntil betReveal betStep) (BetRefDatum previousGuesses previousBet) brAction ctx = + case brAction of + Bet guess -> + let + sOut = case getContinuingOutputs ctx of + [sOut'] -> sOut' + _anyOtherMatch -> traceError "Expected only one continuing output." + outValue = txOutValue sOut + -- Using the 'maybe' utility here makes validation fail... for some reason... + -- Why is PlutusTx still allowed to exist? + inValue = case findOwnInput ctx of + Nothing -> traceError "Joever!" + Just x -> txOutValue (txInInfoResolved x) + -- inValue = txOutValue sIn + (guessesOut, betOut) = case outputToDatum sOut of + Nothing -> traceError "Could not resolve for script output datum" + Just (BetRefDatum guessesOut' betOut') -> (guessesOut', betOut') + in + traceIfFalse + "Must be before `BetUntil` time" + (to betUntil `contains` validRange) && + traceIfFalse + "Guesses update is wrong" + ((signerPkh, guess) : previousGuesses == guessesOut) && + traceIfFalse + "The current bet must be more than the previous bet by atleast `brpBetStep` amount" + (outValue `geq` (inValue <> previousBet <> betStep)) && + traceIfFalse + "Out bet is wrong" + (inValue == outValue - betOut) + Take -> + let + -- Note that `find` returns the first match. Since we were always prepending, this is valid. + Just guess = find ((== signerPkh) . fst) previousGuesses + oracleIn = case filter (isNothing . txOutReferenceScript) (txInInfoResolved <$> txInfoReferenceInputs info) of + [oracleIn'] -> oracleIn' + [] -> traceError "No reference input provided" + _anyOtherMatch -> traceError "Expected only one reference input" + oracleAnswer = case outputToDatum oracleIn of + Nothing -> traceError "Could not resolve for datum" + (Just (OracleAnswerDatum oracleAnswer')) -> oracleAnswer' + guessDiff = getGuessDiff $ snd guess + getGuessDiff (OracleAnswerDatum g) = abs (oracleAnswer - g) + -- Unwrapping the 'Maybe' here to extract the 'Just' (and trace error for 'Nothing') kills PlutusTx compilation + -- the issue is that GHC will fire the worker wrapper transformation combining this with the equality with 'oraclePkh' + -- code down below. Which will cause issues with BuiltinByteString also being unwrapped into primitive pointers. + -- See: https://github.com/IntersectMBO/plutus/issues/4193 + mOracleInPkh = toPubKeyHash (txOutAddress oracleIn) + in + traceIfFalse + "Must be after `RevealTime`" + (from betReveal `contains` validRange) && + traceIfFalse + "Must fully spend Script" + (null (getContinuingOutputs ctx)) && + traceIfFalse + "Reference input must be from Oracle address (wrt Payment part)" + (mOracleInPkh == Just oraclePkh) && + traceIfFalse + "Guess is not closest" + (all (\pg -> getGuessDiff (snd pg) >= guessDiff) previousGuesses) + where + + info :: TxInfo + info = scriptContextTxInfo ctx + + validRange :: POSIXTimeRange + validRange = txInfoValidRange info + + signerPkh :: PubKeyHash + signerPkh = case txInfoSignatories info of + [signerPkh'] -> signerPkh' + [] -> traceError "No signatory" + _anyOtherMatch -> traceError "Expected only one signatory" + + outputToDatum :: FromData b => TxOut -> Maybe b + outputToDatum o = case txOutDatum o of + NoOutputDatum -> Nothing + OutputDatum d -> processDatum d + OutputDatumHash dh -> processDatum =<< findDatum dh info + where processDatum = fromBuiltinData . getDatum \ No newline at end of file diff --git a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef/Compiled.hs b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef/Compiled.hs new file mode 100644 index 00000000..24e3d94c --- /dev/null +++ b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef/Compiled.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-} +-- {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module GeniusYield.Test.Unified.OnChain.BetRef.Compiled + ( betRefValidator + , BetRefParams (..) + , OracleAnswerDatum (..) + , BetRefDatum (..) + , BetRefAction (..) + ) where + +import qualified PlutusTx +import PlutusCore.Version (plcVersion100) + + +import GeniusYield.Test.Unified.OnChain.BetRef + +-- Since makeLift doesn't seem to work on BetRefParams. We just convert it to data and apply that instead. +betRefValidator :: BetRefParams -> PlutusTx.CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()) +betRefValidator betRefParams = + $$(PlutusTx.compile [|| mkBetRefValidator ||]) + `PlutusTx.unsafeApplyCode` PlutusTx.liftCode plcVersion100 (PlutusTx.toBuiltinData betRefParams) diff --git a/tests-unified/atlas-unified-tests.hs b/tests-unified/atlas-unified-tests.hs new file mode 100644 index 00000000..a0c6d6fd --- /dev/null +++ b/tests-unified/atlas-unified-tests.hs @@ -0,0 +1,11 @@ +module Main + ( main + ) where + +import Test.Tasty (defaultMain, testGroup) + +import GeniusYield.Test.Unified.BetRef.PlaceBet +import GeniusYield.Test.Unified.BetRef.TakePot + +main :: IO () +main = defaultMain $ testGroup "BetRef" [placeBetTests, takeBetPotTests] \ No newline at end of file From 0eea3295af05736033cba3fa06df193dfb97427a Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Wed, 17 Jul 2024 11:51:01 -0600 Subject: [PATCH 11/15] Export FeeTracker module from test utils --- src/GeniusYield/Test/Utils.hs | 7 +++++-- tests/GeniusYield/Test/RefInput.hs | 1 - 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index 3cd324ca..9383bc92 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -25,9 +25,11 @@ module GeniusYield.Test.Utils , withMaxQCTests , pattern (:=) , logInfoS + , module X ) where import Control.Lens ((^.)) +import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.Random import Data.List (findIndex) import qualified Data.Map.Strict as Map @@ -62,13 +64,14 @@ import Test.Tasty.HUnit (assertFailure, testCaseInfo) import qualified Test.Tasty.QuickCheck as Tasty import qualified Test.Tasty.Runners as Tasty +import GeniusYield.HTTP.Errors import GeniusYield.Imports import GeniusYield.Test.FakeCoin import GeniusYield.TxBuilder import GeniusYield.Test.Clb import GeniusYield.Types -import GeniusYield.HTTP.Errors -import Control.Monad.Except + +import GeniusYield.Test.FeeTracker as X ------------------------------------------------------------------------------- -- tasty tools diff --git a/tests/GeniusYield/Test/RefInput.hs b/tests/GeniusYield/Test/RefInput.hs index 803619de..e6d998b0 100644 --- a/tests/GeniusYield/Test/RefInput.hs +++ b/tests/GeniusYield/Test/RefInput.hs @@ -19,7 +19,6 @@ import Test.Tasty (TestTree, import GeniusYield.Imports import GeniusYield.HTTP.Errors import GeniusYield.Test.Clb -import GeniusYield.Test.FeeTracker import GeniusYield.Test.OnChain.GuessRefInputDatum.Compiled import GeniusYield.Test.Utils import GeniusYield.Transaction From 257e94384eb3b4f36db31e3107655a9f4b506010 Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Wed, 17 Jul 2024 12:00:23 -0600 Subject: [PATCH 12/15] Use `withWalletBalancesCheckSimple` to avoid having to deal with fee expectations --- .../Test/Unified/BetRef/PlaceBet.hs | 13 ++++----- .../Test/Unified/BetRef/TakePot.hs | 28 +++++++------------ 2 files changed, 16 insertions(+), 25 deletions(-) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index 2e71c305..25dacfa7 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -22,7 +22,7 @@ placeBetTests :: TestTree placeBetTests = testGroup "Place Bet" [ mkTestFor "Simple spending tx" simplSpendingTxTrace , mkTestFor "Balance checks after placing first bet" $ - firstBetTrace (OracleAnswerDatum 3) (valueFromLovelace 20_000_000) 0_176_545 + firstBetTrace (OracleAnswerDatum 3) (valueFromLovelace 20_000_000) , mkTestFor "Balance checks with multiple bets" $ multipleBetsTraceWrapper 400 1_000 (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) @@ -47,14 +47,14 @@ simplSpendingTxTrace :: Wallets -> GYTxMonadClb () simplSpendingTxTrace Wallets{w1} = do gyLogDebug' "" "Hey there!" -- balance assetion check - void . withWalletBalancesCheck [w1 := valueNegate (valueFromLovelace 100_173_685)] . asUser w1 $ do -- TODO: w1 is the wallets that gets all funds for now + void . withWalletBalancesCheckSimple [w1 := valueFromLovelace (-100_000_000)] . asUser w1 $ do -- TODO: w1 is the wallets that gets all funds for now skeleton <- mkTrivialTx gyLogDebug' "" $ printf "tx skeleton: %s" (show skeleton) - dumpUtxoState + ftLift dumpUtxoState -- test itself txId <- buildTxBody skeleton >>= signAndSubmitConfirmed - dumpUtxoState + ftLift dumpUtxoState gyLogDebug' "" $ printf "tx submitted, txId: %s" txId -- Pretend off-chain code written in 'GYTxMonad m' @@ -92,14 +92,13 @@ Level 3. The action (Off-chain code) -- | Trace for placing the first bet. firstBetTrace :: OracleAnswerDatum -- ^ Guess -> GYValue -- ^ Bet - -> Integer -- ^ Expected fees -> Wallets -> GYTxMonadClb () -- Our continuation function -firstBetTrace dat bet expectedFees ws@Wallets{w1} = do +firstBetTrace dat bet ws@Wallets{w1} = do -- First step: Get the required parameters for initializing our parameterized script, -- claculate the script, and post it to the blockchain as a reference script. (brp, refScript) <- computeParamsAndAddRefScript 40 100 (valueFromLovelace 200_000_000) ws - void . withWalletBalancesCheck [w1 := valueNegate (valueFromLovelace expectedFees <> bet)] . asUser w1 $ do -- following operations are ran by first wallet, `w1` + void . withWalletBalancesCheckSimple [w1 := valueNegate bet] . asUser w1 $ do -- following operations are ran by first wallet, `w1` -- Second step: Perform the actual run. placeBetRun refScript brp dat bet Nothing diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs index b98bd428..d5d970c1 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -25,7 +25,7 @@ takeBetPotTests = testGroup "Take bet pot" , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> fakeGold 1_000) ] - 4 w2 (Just 0_327_625) + 4 w2 , mkTestFor "Must fail if attempt to take is by wrong guesser" $ mustFail . takeBetsTrace 400 1_000 (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) @@ -34,7 +34,7 @@ takeBetPotTests = testGroup "Take bet pot" , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> fakeGold 1_000) ] - 5 w2 Nothing + 5 w2 , mkTestFor "Must fail even if old guess was closest but updated one is not" $ mustFail . takeBetsTrace 400 1_000 (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) @@ -43,7 +43,7 @@ takeBetPotTests = testGroup "Take bet pot" , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> fakeGold 1_000) ] - 2 w2 Nothing + 2 w2 ] -- | Run to call the `takeBets` operation. @@ -60,9 +60,8 @@ takeBetsTrace :: Integer -- ^ slot fo -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets -> Integer -- ^ Actual answer -> (Wallets -> User) -- ^ Taker - -> Maybe Integer -- ^ Expected fees -> Wallets -> GYTxMonadClb () -- Our continuation function -takeBetsTrace betUntil' betReveal' betStep walletBets answer getTaker mExpectedFees ws@Wallets{..} = do +takeBetsTrace betUntil' betReveal' betStep walletBets answer getTaker ws@Wallets{..} = do (brp, refScript) <- computeParamsAndAddRefScript betUntil' betReveal' betStep ws multipleBetsTraceCore brp refScript walletBets ws -- Now lets take the bet @@ -70,16 +69,9 @@ takeBetsTrace betUntil' betReveal' betStep walletBets answer getTaker mExpectedF let taker = getTaker ws case ref of Just refInput -> do - void $ asUser taker $ do - betRefAddr <- betRefAddress brp - [_scriptUtxo@GYUTxO {utxoRef, utxoValue}] <- utxosToList <$> utxosAtAddress betRefAddr Nothing - gyLogInfo' "" "Slot await complete" - waitUntilSlot_ $ slotFromApi (fromInteger betReveal') - gyLogInfo' "" "Slot await complete" - case mExpectedFees of - Just expectedFees -> do - withWalletBalancesCheck [taker := utxoValue <> valueNegate (valueFromLovelace expectedFees)] $ do - gyLogDebug' "" (show utxoValue) - takeBetsRun refScript brp utxoRef refInput - Nothing -> takeBetsRun refScript brp utxoRef refInput - _ -> fail "Couldn't place reference input successfully" \ No newline at end of file + betRefAddr <- betRefAddress brp + [_scriptUtxo@GYUTxO {utxoRef, utxoValue}] <- utxosToList <$> utxosAtAddress betRefAddr Nothing + waitUntilSlot_ $ slotFromApi (fromInteger betReveal') + void . withWalletBalancesCheckSimple [taker := utxoValue] . asUser taker + $ takeBetsRun refScript brp utxoRef refInput + _ -> fail "Couldn't place reference input successfully" From fe47004d3522f6dee1574c367e32ce59cdb9adaf Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Wed, 17 Jul 2024 13:28:04 -0600 Subject: [PATCH 13/15] Long overdue Clb utils cleanup --- src/GeniusYield/Test/Clb.hs | 93 +++++++++++--- src/GeniusYield/Test/Utils.hs | 190 +++++++---------------------- tests/GeniusYield/Test/RefInput.hs | 33 +++-- 3 files changed, 135 insertions(+), 181 deletions(-) diff --git a/src/GeniusYield/Test/Clb.hs b/src/GeniusYield/Test/Clb.hs index 02ec5667..f3882c25 100644 --- a/src/GeniusYield/Test/Clb.hs +++ b/src/GeniusYield/Test/Clb.hs @@ -10,6 +10,7 @@ Stability : develop -} module GeniusYield.Test.Clb ( GYTxMonadClb + , mkTestFor , asClb , asRandClb , liftClb @@ -30,6 +31,7 @@ import Data.SOP.NonEmpty (NonEmpty (NonEmptyCo import Data.Time.Clock (NominalDiffTime, UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import qualified Data.Text as T import qualified Cardano.Api as Api import qualified Cardano.Api.Script as Api @@ -50,18 +52,28 @@ import Clb (ClbState (..), ClbT, ValidationResult (..), getCurrentSlot, txOutRefAt, txOutRefAtPaymentCred, sendTx, unLog, getFails, logInfo, logError, waitSlot) -import qualified Clb (dumpUtxoState) +import qualified Clb import Control.Monad.Trans.Maybe (runMaybeT) import qualified Ouroboros.Consensus.Cardano.Block as Ouroboros import qualified Ouroboros.Consensus.HardFork.History as Ouroboros import qualified PlutusLedgerApi.V2 as Plutus - +import Prettyprinter (PageWidth (AvailablePerLine), + defaultLayoutOptions, + layoutPageWidth, + layoutPretty) +import Prettyprinter.Render.String (renderString) +import qualified Test.Cardano.Ledger.Core.KeyPair as TL +import qualified Test.Tasty as Tasty +import Test.Tasty.HUnit (assertFailure, testCaseInfo) + +import GeniusYield.HTTP.Errors import GeniusYield.Imports import GeniusYield.TxBuilder.Class import GeniusYield.TxBuilder.Common import GeniusYield.TxBuilder.Errors import GeniusYield.TxBuilder.User import GeniusYield.Types +import GeniusYield.Test.Utils -- FIXME: Fix this type synonym upstream. type Clb = ClbT Identity @@ -69,7 +81,7 @@ type Clb = ClbT Identity newtype GYTxRunEnv = GYTxRunEnv { runEnvWallet :: User } newtype GYTxMonadClb a = GYTxMonadClb - { unGYTxMonadClb :: ReaderT GYTxRunEnv (ExceptT (Either String GYTxMonadException) (RandT StdGen Clb)) a + { unGYTxMonadClb :: ReaderT GYTxRunEnv (ExceptT GYTxMonadException (RandT StdGen Clb)) a } deriving newtype (Functor, Applicative, Monad, MonadReader GYTxRunEnv) deriving anyclass GYTxBuilderMonad @@ -86,9 +98,8 @@ asRandClb :: User asRandClb w m = do e <- runExceptT $ unGYTxMonadClb m `runReaderT` GYTxRunEnv w case e of - Left (Left err) -> lift (logError err) >> return Nothing - Left (Right err) -> lift (logError (show err)) >> return Nothing - Right a -> return $ Just a + Left err -> lift (logError (show err)) >> return Nothing + Right a -> return $ Just a asClb :: StdGen -> User @@ -99,6 +110,58 @@ asClb g w m = evalRandT (asRandClb w m) g liftClb :: Clb a -> GYTxMonadClb a liftClb = GYTxMonadClb . lift . lift . lift +{- | Given a test name, runs the trace for every wallet, checking there weren't + errors. +-} +mkTestFor :: String -> (Wallets -> GYTxMonadClb a) -> Tasty.TestTree +mkTestFor name action = + testNoErrorsTraceClb v w Clb.defaultBabbage name $ do + asClb pureGen (w1 wallets) $ action wallets + where + v = valueFromLovelace 1_000_000_000_000_000 <> + fakeGold 1_000_000_000 <> + fakeIron 1_000_000_000 + + w = valueFromLovelace 1_000_000_000_000 <> + fakeGold 1_000_000 <> + fakeIron 1_000_000 + + wallets :: Wallets + wallets = Wallets (mkSimpleWallet (Clb.intToKeyPair 1)) + (mkSimpleWallet (Clb.intToKeyPair 2)) + (mkSimpleWallet (Clb.intToKeyPair 3)) + (mkSimpleWallet (Clb.intToKeyPair 4)) + (mkSimpleWallet (Clb.intToKeyPair 5)) + (mkSimpleWallet (Clb.intToKeyPair 6)) + (mkSimpleWallet (Clb.intToKeyPair 7)) + (mkSimpleWallet (Clb.intToKeyPair 8)) + (mkSimpleWallet (Clb.intToKeyPair 9)) + + -- | Helper for building tests + testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.MockConfig -> String -> Clb a -> Tasty.TestTree + testNoErrorsTraceClb funds walletFunds cfg msg act = + testCaseInfo msg + $ maybe (pure mockLog) assertFailure + $ mbErrors >>= \errors -> pure (mockLog <> "\n\nError :\n-------\n" <> errors) + where + -- _errors since we decided to store errors in the log as well. + (mbErrors, mock) = Clb.runClb (act >> Clb.checkErrors) $ Clb.initClb cfg (valueToApi funds) (valueToApi walletFunds) + mockLog = "\nEmulator log :\n--------------\n" <> logString + options = defaultLayoutOptions { layoutPageWidth = AvailablePerLine 150 1.0} + logDoc = Clb.ppLog $ Clb.mockInfo mock + logString = renderString $ layoutPretty options logDoc + + + mkSimpleWallet :: TL.KeyPair r L.StandardCrypto -> User + mkSimpleWallet kp = + let key = paymentSigningKeyFromLedgerKeyPair kp + in User' + { userPaymentSKey' = key + , userStakeSKey' = Nothing + , userAddr = addressFromPaymentKeyHash GYTestnetPreprod . paymentKeyHash $ + paymentVerificationKey key + } + {- | Try to execute an action, and if it fails, restore to the current state while preserving logs. If the action succeeds, logs an error as we expect it to fail. Use 'mustFailWith' to provide custom @@ -131,16 +194,11 @@ mustFailWith isExpectedError act = do Log $ second (LogEntry Error . ((msg <> ":") <> ). show) <$> Seq.drop (Seq.length pre) post msg = "Unnamed failure action" -instance MonadFail GYTxMonadClb where - fail = GYTxMonadClb . throwError . Left - instance MonadError GYTxMonadException GYTxMonadClb where - throwError = GYTxMonadClb . throwError . Right + throwError = GYTxMonadClb . throwError - catchError m handler = GYTxMonadClb $ catchError (unGYTxMonadClb m) $ \case - Left err -> throwError $ Left err - Right err -> unGYTxMonadClb $ handler err + catchError m handler = GYTxMonadClb . catchError (unGYTxMonadClb m) $ unGYTxMonadClb . handler instance GYTxQueryMonad GYTxMonadClb where @@ -285,7 +343,7 @@ instance GYTxMonad GYTxMonadClb where vRes <- liftClb . sendTx $ txToApi tx case vRes of Success _state _onChainTx -> pure $ txBodyTxId txBody - Fail _ err -> fail $ show err + Fail _ err -> throwAppError . someBackendError . T.pack $ show err where -- TODO: use Prettyprinter dumpBody :: GYTxBody -> GYTxMonadClb () @@ -414,3 +472,10 @@ instance GYTxSpecialQueryMonad GYTxMonadClb where dumpUtxoState :: GYTxMonadClb () dumpUtxoState = liftClb Clb.dumpUtxoState +------------------------------------------------------------------------------- +-- Preset StdGen +------------------------------------------------------------------------------- + +pureGen :: StdGen +pureGen = mkStdGen 42 + diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index 9383bc92..4a6bf59d 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -9,9 +9,7 @@ Stability : develop -} module GeniusYield.Test.Utils - ( Clb.Clb - , mkTestFor - , Wallets (..) + ( Wallets (..) , withBalance , withWalletBalancesCheck , findLockedUtxosInBody @@ -24,43 +22,17 @@ module GeniusYield.Test.Utils , feesFromLovelace , withMaxQCTests , pattern (:=) - , logInfoS , module X ) where -import Control.Lens ((^.)) import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.Random -import Data.List (findIndex) import qualified Data.Map.Strict as Map import qualified Data.Text as T -import qualified Data.Sequence.Strict as StrictSeq -import Prettyprinter (PageWidth (AvailablePerLine), - defaultLayoutOptions, - layoutPageWidth, - layoutPretty) -import Prettyprinter.Render.String (renderString) - -import qualified Cardano.Api.Shelley as Api.S -import qualified Cardano.Ledger.Address as L -import qualified Cardano.Ledger.Api as L -import qualified Cardano.Ledger.Babbage.Tx as L.B -import qualified Cardano.Ledger.Babbage.TxOut as L.B -import qualified Cardano.Ledger.Binary as L -import qualified Clb (Clb, ClbState (mockInfo), - ClbT, LogEntry (..), - LogLevel (..), MockConfig, - checkErrors, defaultBabbage, - initClb, intToKeyPair, - logInfo, ppLog, runClb) import qualified PlutusLedgerApi.V1.Value as Plutus -import qualified PlutusLedgerApi.V2 as PlutusV2 - -import qualified Test.Cardano.Ledger.Core.KeyPair as TL import qualified Test.Tasty as Tasty -import Test.Tasty.HUnit (assertFailure, testCaseInfo) import qualified Test.Tasty.QuickCheck as Tasty import qualified Test.Tasty.Runners as Tasty @@ -68,7 +40,6 @@ import GeniusYield.HTTP.Errors import GeniusYield.Imports import GeniusYield.Test.FakeCoin import GeniusYield.TxBuilder -import GeniusYield.Test.Clb import GeniusYield.Types import GeniusYield.Test.FeeTracker as X @@ -126,58 +97,6 @@ fakeIron = fromFakeCoin $ FakeCoin "Iron" -- helpers ------------------------------------------------------------------------------- -{- | Given a test name, runs the trace for every wallet, checking there weren't - errors. --} -mkTestFor :: String -> (Wallets -> GYTxMonadClb a) -> Tasty.TestTree -mkTestFor name action = - testNoErrorsTraceClb v w Clb.defaultBabbage name $ do - asClb pureGen (w1 wallets) $ action wallets - where - v = valueFromLovelace 1_000_000_000_000_000 <> - fakeGold 1_000_000_000 <> - fakeIron 1_000_000_000 - - w = valueFromLovelace 1_000_000_000_000 <> - fakeGold 1_000_000 <> - fakeIron 1_000_000 - - wallets :: Wallets - wallets = Wallets (mkSimpleWallet (Clb.intToKeyPair 1)) - (mkSimpleWallet (Clb.intToKeyPair 2)) - (mkSimpleWallet (Clb.intToKeyPair 3)) - (mkSimpleWallet (Clb.intToKeyPair 4)) - (mkSimpleWallet (Clb.intToKeyPair 5)) - (mkSimpleWallet (Clb.intToKeyPair 6)) - (mkSimpleWallet (Clb.intToKeyPair 7)) - (mkSimpleWallet (Clb.intToKeyPair 8)) - (mkSimpleWallet (Clb.intToKeyPair 9)) - - -- | Helper for building tests - testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.MockConfig -> String -> Clb.Clb a -> Tasty.TestTree - testNoErrorsTraceClb funds walletFunds cfg msg act = - testCaseInfo msg - $ maybe (pure mockLog) assertFailure - $ mbErrors >>= \errors -> pure (mockLog <> "\n\nError :\n-------\n" <> errors) - where - -- _errors since we decided to store errors in the log as well. - (mbErrors, mock) = Clb.runClb (act >> Clb.checkErrors) $ Clb.initClb cfg (valueToApi funds) (valueToApi walletFunds) - mockLog = "\nEmulator log :\n--------------\n" <> logString - options = defaultLayoutOptions { layoutPageWidth = AvailablePerLine 150 1.0} - logDoc = Clb.ppLog $ Clb.mockInfo mock - logString = renderString $ layoutPretty options logDoc - - - mkSimpleWallet :: TL.KeyPair r L.StandardCrypto -> User - mkSimpleWallet kp = - let key = paymentSigningKeyFromLedgerKeyPair kp - in User' - { userPaymentSKey' = key - , userStakeSKey' = Nothing - , userAddr = addressFromPaymentKeyHash GYTestnetPreprod . paymentKeyHash $ - paymentVerificationKey key - } - -- | Available wallets. data Wallets = Wallets { w1 :: !User @@ -224,13 +143,11 @@ withWalletBalancesCheck ((w, v) : xs) m = do findLockedUtxosInBody :: Num a => GYAddress -> GYTx -> Maybe [a] findLockedUtxosInBody addr tx = let - os = getTxOutputs tx + os = utxosToList . txBodyUTxOs $ getTxBody tx findAllMatches (_, [], acc) = Just acc - findAllMatches (index, txOut : os', acc) = - let txOutAddr = addressFromApi . Api.S.fromShelleyAddrToAny . either id L.decompactAddr $ L.B.getEitherAddrBabbageTxOut txOut - in if txOutAddr == addr - then findAllMatches (index + 1, os', index : acc) - else findAllMatches (index + 1, os', acc) + findAllMatches (index, txOut : os', acc) = if utxoAddress txOut == addr + then findAllMatches (index + 1, os', index : acc) + else findAllMatches (index + 1, os', acc) in findAllMatches (0, os, []) @@ -269,63 +186,35 @@ addRefScript addr sc = throwAppError absurdError `runEagerT` do lift $ signAndSubmitConfirmed_ txBody maybeToEager . Map.lookup (Some sc) $ findRefScriptsInBody txBody where - -- The above function is written utilizing 'ExceptT' as a "eager" transformer. - -- 'Left' does not indicate failure, rather it indicates that "target value has - -- been obtained" and that we can exit eagerly. - -- | If we have a 'Just' value, we can exit with it immediately. So it gets converted - -- to 'Left'. - maybeToEager :: Maybe a -> ExceptT a m () - maybeToEager (Just a) = throwError a - maybeToEager Nothing = pure () absurdError = someBackendError "Shouldn't happen: no ref in body" - -- If all goes well, we should finish with a 'Left'. if not, we perform the - -- given action to signal error. - runEagerT :: m a -> ExceptT a m () -> m a - runEagerT whenError = runExceptT >=> either pure (const whenError) -- | Adds an input (whose datum we'll refer later) and returns the reference to it. addRefInput :: GYTxMonad m => Bool -- ^ Whether to inline this datum? -> GYAddress -- ^ Where to place this output? -> GYDatum -- ^ Our datum. - -> m (Maybe GYTxOutRef) -addRefInput toInline addr dat = do - txBody <- buildTxBody - (mustHaveOutput + -> m GYTxOutRef +addRefInput toInline addr dat = throwAppError absurdError `runEagerT` do + existingUtxos <- lift $ utxosAtAddress addr Nothing + maybeToEager $ findRefWithDatum existingUtxos + txBody <- lift . buildTxBody . + mustHaveOutput $ GYTxOut addr mempty (Just (dat, if toInline then GYTxOutUseInlineDatum else GYTxOutDontUseInlineDatum)) Nothing - ) - tx@(txToApi -> Api.S.ShelleyTx _ ledgerTx) <- signTxBody txBody - txId <- submitTxConfirmed tx - - let L.TxDats datumMap = ledgerTx ^. L.witsTxL . L.datsTxWitsL - datumWits = datumFromLedgerData <$> datumMap - let outputsWithResolvedDatums = map - (\o -> - resolveDatumFromLedger datumWits $ o ^. L.B.datumBabbageTxOutL + + lift $ signAndSubmitConfirmed_ txBody + maybeToEager . findRefWithDatum $ txBodyUTxOs txBody + where + findRefWithDatum :: GYUTxOs -> Maybe GYTxOutRef + findRefWithDatum utxos = fmap utxoRef + . find + (\GYUTxO {utxoOutDatum} -> + case utxoOutDatum of + GYOutDatumHash dh -> hashDatum dat == dh + GYOutDatumInline dat' -> dat == dat' + _ -> False ) - $ getTxOutputs tx - let mIndex = findIndex (\d -> Just dat == d) outputsWithResolvedDatums - pure $ (Just . txOutRefFromApiTxIdIx (txIdToApi txId) . wordToApiIx . fromInteger) . toInteger =<< mIndex - -resolveDatumFromLedger :: L.Era era => Map (L.DataHash (L.EraCrypto era)) GYDatum -> L.Datum era -> Maybe GYDatum -resolveDatumFromLedger _ (L.Datum d) = Just - . datumFromLedgerData - $ L.binaryDataToData d -resolveDatumFromLedger datumMap (L.DatumHash dh) = Map.lookup dh datumMap -resolveDatumFromLedger _ L.NoDatum = Nothing - --- TODO: Add to CLB upstream? -getTxOutputs :: GYTx -> [L.B.BabbageTxOut (L.BabbageEra L.StandardCrypto)] -getTxOutputs (txToApi -> Api.S.ShelleyTx _ ledgerTx) = fmap L.sizedValue - . toList - . StrictSeq.fromStrict - . L.B.btbOutputs - $ L.B.body ledgerTx - -datumFromLedgerData :: L.Data era -> GYDatum -datumFromLedgerData = datumFromPlutusData - . PlutusV2.BuiltinData - . L.getPlutusData + $ utxosToList utxos + absurdError = someBackendError "Shouldn't happen: no output with expected datum in body" {- | Abstraction for explicitly building a Value representing the fees of a transaction. @@ -343,17 +232,20 @@ pattern (:=) x y = (x, y) infix 0 := -------------------------------------------------------------------------------- --- Preset StdGen -------------------------------------------------------------------------------- - -pureGen :: StdGen -pureGen = mkStdGen 42 - -{- ----------------------------------------------------------------------------- - CLB ------------------------------------------------------------------------------ -} +{- | Utilizing 'ExceptT' as a "eager monad" transformer. --- | Variant of `logInfo` from @Clb@ that logs a string with @Info@ severity. -logInfoS :: Monad m => String -> Clb.ClbT m () -logInfoS s = Clb.logInfo $ Clb.LogEntry Clb.Info s +'Left' does not indicate failure, rather it indicates that "target value has been obtained" +and that we can exit eagerly. +-} +type EagerT m a = ExceptT a m () + +-- | If we have a 'Just' value, we can exit with it immediately. So it gets converted +-- to 'Left'. +maybeToEager :: Monad m => Maybe a -> EagerT m a +maybeToEager (Just a) = throwError a +maybeToEager Nothing = pure () + +-- If all goes well, we should finish with a 'Left'. if not, we perform the +-- given action to signal error. +runEagerT :: Monad m => m a -> ExceptT a m () -> m a +runEagerT whenError = runExceptT >=> either pure (const whenError) diff --git a/tests/GeniusYield/Test/RefInput.hs b/tests/GeniusYield/Test/RefInput.hs index e6d998b0..0a786ca9 100644 --- a/tests/GeniusYield/Test/RefInput.hs +++ b/tests/GeniusYield/Test/RefInput.hs @@ -55,28 +55,25 @@ refInputTrace :: GYTxGameMonad m => Bool -> Integer -> Integer -> Wallets -> m ( refInputTrace toInline actual guess Wallets{..} = do let myGuess :: Integer = guess outValue :: GYValue = valueFromLovelace 20_000_000 - mMOref <- asUser w1 $ addRefInput toInline (userAddr w9) (datumFromPlutusData (RefInputDatum actual)) - case mMOref of - Nothing -> throwAppError $ someBackendError "Couldn't find index for reference utxo in outputs" - Just refInputORef -> - withWalletBalancesCheckSimple [w1 := valueFromLovelace 0] . asUser w1 $ do - gyLogInfo' "" $ printf "Reference input ORef %s" refInputORef - addr <- scriptAddress gyGuessRefInputDatumValidator - txBody <- buildTxBody . mustHaveOutput $ mkGYTxOut addr outValue (datumFromPlutusData ()) - tx <- signTxBody txBody - txId <- submitTxConfirmed tx - let mOrefIndices = findLockedUtxosInBody addr tx - orefIndices <- maybe (throwAppError . someBackendError $ "Unable to get GYAddress from some Plutus.Address in txBody") return mOrefIndices - oref <- case fmap (txOutRefFromApiTxIdIx (txIdToApi txId) . wordToApiIx) orefIndices of - [oref'] -> return oref' - _non_singleton -> throwAppError . someBackendError $ "expected exactly one reference" - gyLogInfo' "" $ printf "Locked ORef %s" oref - guessRefInputRun refInputORef oref myGuess + refInputORef <- asUser w1 $ addRefInput toInline (userAddr w9) (datumFromPlutusData (RefInputDatum actual)) + withWalletBalancesCheckSimple [w1 := valueFromLovelace 0] . asUser w1 $ do + gyLogInfo' "" $ printf "Reference input ORef %s" refInputORef + addr <- scriptAddress gyGuessRefInputDatumValidator + txBody <- buildTxBody . mustHaveOutput $ mkGYTxOut addr outValue (datumFromPlutusData ()) + tx <- signTxBody txBody + txId <- submitTxConfirmed tx + let mOrefIndices = findLockedUtxosInBody addr tx + orefIndices <- maybe (throwAppError . someBackendError $ "Unable to get GYAddress from some Plutus.Address in txBody") return mOrefIndices + oref <- case fmap (txOutRefFromApiTxIdIx (txIdToApi txId) . wordToApiIx) orefIndices of + [oref'] -> return oref' + _non_singleton -> throwAppError . someBackendError $ "expected exactly one reference" + gyLogInfo' "" $ printf "Locked ORef %s" oref + guessRefInputRun refInputORef oref myGuess tryRefInputConsume :: GYTxGameMonad m => Wallets -> m () tryRefInputConsume Wallets{..} = do -- Approach: Create a new output with 60% of total ada. Mark this UTxO as reference input and try sending this same 60%, or any amount greater than 40% of this original balance. Since coin balancer can't consume this UTxO, it won't be able to build for it. - void $ asUser w1 $ do + asUser w1 $ do walletBalance <- queryBalance $ userAddr w1 let walletLovelaceBalance = fst $ valueSplitAda walletBalance lovelaceToSend = (walletLovelaceBalance `div` 10) * 6 -- send 60% of total ada From a97958128cd60dbed01afd1756f0b68c197de023 Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Wed, 17 Jul 2024 13:33:57 -0600 Subject: [PATCH 14/15] Export transaction building errors from `GeniusYield.TxBuilder.Errors` --- src/GeniusYield/TxBuilder/Errors.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/GeniusYield/TxBuilder/Errors.hs b/src/GeniusYield/TxBuilder/Errors.hs index 338cd999..d1a2a66b 100644 --- a/src/GeniusYield/TxBuilder/Errors.hs +++ b/src/GeniusYield/TxBuilder/Errors.hs @@ -12,6 +12,8 @@ module GeniusYield.TxBuilder.Errors , GYQueryUTxOError (..) , GYQueryDatumError (..) , GYTxMonadException (..) + , GYBuildTxError (..) + , GYBalancingError (..) , throwAppError ) where From d29b6de1dd17cced5eefed3f8c813ede791db118 Mon Sep 17 00:00:00 2001 From: TotallyNotChase <44284917+TotallyNotChase@users.noreply.github.com> Date: Sun, 21 Jul 2024 12:03:40 -0600 Subject: [PATCH 15/15] Run the same tests in both Privnet and CLB! --- atlas-cardano.cabal | 1 + src/GeniusYield/Test/Clb.hs | 9 +- src/GeniusYield/Test/Privnet/Ctx.hs | 18 +++ src/GeniusYield/Test/Privnet/Examples/Gift.hs | 7 +- src/GeniusYield/Test/Privnet/Setup.hs | 47 ++++---- src/GeniusYield/Test/Utils.hs | 6 +- .../Test/Unified/BetRef/Operations.hs | 2 +- .../Test/Unified/BetRef/PlaceBet.hs | 107 +++++++++++------- .../Test/Unified/BetRef/TakePot.hs | 79 ++++++++----- tests-unified/atlas-unified-tests.hs | 5 +- tests/GeniusYield/Test/RefInput.hs | 5 +- 11 files changed, 186 insertions(+), 100 deletions(-) diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index 8922cf25..c2e08680 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -375,6 +375,7 @@ test-suite atlas-unified-tests , containers , tasty , tasty-hunit + , text , mtl -- OnChain , plutus-core diff --git a/src/GeniusYield/Test/Clb.hs b/src/GeniusYield/Test/Clb.hs index f3882c25..be23c483 100644 --- a/src/GeniusYield/Test/Clb.hs +++ b/src/GeniusYield/Test/Clb.hs @@ -113,10 +113,10 @@ liftClb = GYTxMonadClb . lift . lift . lift {- | Given a test name, runs the trace for every wallet, checking there weren't errors. -} -mkTestFor :: String -> (Wallets -> GYTxMonadClb a) -> Tasty.TestTree +mkTestFor :: String -> (TestInfo -> GYTxMonadClb a) -> Tasty.TestTree mkTestFor name action = testNoErrorsTraceClb v w Clb.defaultBabbage name $ do - asClb pureGen (w1 wallets) $ action wallets + asClb pureGen (w1 testWallets) $ action TestInfo { testGoldAsset = fakeGold, testIronAsset = fakeIron, testWallets } where v = valueFromLovelace 1_000_000_000_000_000 <> fakeGold 1_000_000_000 <> @@ -126,8 +126,9 @@ mkTestFor name action = fakeGold 1_000_000 <> fakeIron 1_000_000 - wallets :: Wallets - wallets = Wallets (mkSimpleWallet (Clb.intToKeyPair 1)) + testWallets :: Wallets + testWallets = Wallets + (mkSimpleWallet (Clb.intToKeyPair 1)) (mkSimpleWallet (Clb.intToKeyPair 2)) (mkSimpleWallet (Clb.intToKeyPair 3)) (mkSimpleWallet (Clb.intToKeyPair 4)) diff --git a/src/GeniusYield/Test/Privnet/Ctx.hs b/src/GeniusYield/Test/Privnet/Ctx.hs index afb91d2b..4ee26a63 100644 --- a/src/GeniusYield/Test/Privnet/Ctx.hs +++ b/src/GeniusYield/Test/Privnet/Ctx.hs @@ -14,6 +14,7 @@ module GeniusYield.Test.Privnet.Ctx ( User (..), CreateUserConfig (..), ctxUsers, + ctxWallets, userPkh, userPaymentPkh, userStakePkh, @@ -21,6 +22,7 @@ module GeniusYield.Test.Privnet.Ctx ( userPaymentVKey, userStakeVKey, -- * Operations + ctxRunGame, ctxRun, ctxRunQuery, ctxRunBuilder, @@ -42,6 +44,7 @@ import GeniusYield.Imports import GeniusYield.Providers.Node import GeniusYield.TxBuilder import GeniusYield.Types +import GeniusYield.Test.Utils import Test.Tasty.HUnit (assertFailure) data CreateUserConfig = @@ -86,6 +89,19 @@ ctxNetworkId Ctx {ctxNetworkInfo} = GYPrivnet ctxNetworkInfo ctxUsers :: Ctx -> [User] ctxUsers ctx = ($ ctx) <$> [ctxUser2, ctxUser3, ctxUser4, ctxUser5, ctxUser6, ctxUser7, ctxUser8, ctxUser9] +ctxWallets :: Ctx -> Wallets +ctxWallets Ctx{..} = Wallets + { w1 = ctxUserF + , w2 = ctxUser2 + , w3 = ctxUser3 + , w4 = ctxUser4 + , w5 = ctxUser5 + , w6 = ctxUser6 + , w7 = ctxUser7 + , w8 = ctxUser8 + , w9 = ctxUser9 + } + -- | Creates a new user with the given balance. Note that the actual balance which this user get's could be more than what is provided to satisfy minimum ada requirement of a UTxO. newTempUserCtx:: Ctx -> User -- ^ User which will fund this new user. @@ -117,6 +133,8 @@ newTempUserCtx ctx fundUser fundValue CreateUserConfig {..} = do pure $ User' {userPaymentSKey' = newPaymentSKey, userAddr = newAddr, userStakeSKey' = newStakeSKey} +ctxRunGame :: Ctx -> GYTxGameMonadIO a -> IO a +ctxRunGame ctx = runGYTxGameMonadIO (ctxNetworkId ctx) (ctxProviders ctx) ctxRun :: Ctx -> User -> GYTxMonadIO a -> IO a ctxRun ctx User' {..} = runGYTxMonadIO (ctxNetworkId ctx) (ctxProviders ctx) userPaymentSKey' userStakeSKey' [userAddr] userAddr Nothing diff --git a/src/GeniusYield/Test/Privnet/Examples/Gift.hs b/src/GeniusYield/Test/Privnet/Examples/Gift.hs index 21961625..96559258 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Gift.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Gift.hs @@ -20,22 +20,21 @@ import Control.Lens ((.~)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCaseSteps) +import Data.Default (Default (def)) import Data.Maybe (fromJust) import Data.Ratio ((%)) import qualified Data.Set as Set -import GeniusYield.Imports -import GeniusYield.Transaction -import GeniusYield.Types -import Data.Default (Default (def)) import GeniusYield.Examples.Gift import GeniusYield.Examples.Treat +import GeniusYield.Imports import GeniusYield.Providers.Common (SubmitTxException) import GeniusYield.Test.Privnet.Asserts import GeniusYield.Test.Privnet.Ctx import GeniusYield.Test.Privnet.Examples.Common import GeniusYield.Test.Privnet.Setup import GeniusYield.TxBuilder +import GeniusYield.Types pattern InsufficientFundsException :: GYTxMonadException pattern InsufficientFundsException <- GYBuildTxException (GYBuildTxBalancingError (GYBalancingErrorInsufficientFunds _)) diff --git a/src/GeniusYield/Test/Privnet/Setup.hs b/src/GeniusYield/Test/Privnet/Setup.hs index a9127916..9122f29a 100644 --- a/src/GeniusYield/Test/Privnet/Setup.hs +++ b/src/GeniusYield/Test/Privnet/Setup.hs @@ -12,6 +12,8 @@ module GeniusYield.Test.Privnet.Setup ( withSetup, withSetup', withSetupOld, + mkPrivnetTestFor, + mkPrivnetTestFor', -- * "Cardano.Testnet" re-exports cardanoDefaultTestnetOptions, cardanoDefaultTestnetNodeOptions, @@ -32,6 +34,8 @@ import qualified Data.Vector as V import qualified Hedgehog as H import qualified Hedgehog.Extras.Stock as H' +import Test.Tasty (TestName, TestTree) +import Test.Tasty.HUnit (testCaseSteps) import qualified Cardano.Api as Api import Cardano.Testnet @@ -47,6 +51,7 @@ import GeniusYield.Providers.Node.AwaitTx (nodeAwaitTxConfirmed) import GeniusYield.Providers.Node.Query (nodeQueryUTxO) import GeniusYield.Test.Privnet.Ctx import GeniusYield.Test.Privnet.Utils +import GeniusYield.Test.Utils import GeniusYield.TxBuilder import GeniusYield.Types @@ -82,6 +87,15 @@ withSetup' :: GYLogSeverity -> (String -> IO ()) -> Setup -> (Ctx -> IO ()) -> I withSetup' targetSev putLog (Setup cokont) kont = do cokont targetSev putLog kont +-- | Given a test name, runs the test under privnet. +mkPrivnetTestFor :: TestName -> Setup -> (TestInfo -> GYTxGameMonadIO ()) -> TestTree +mkPrivnetTestFor name = mkPrivnetTestFor' name GYInfo + +-- | Given a test name, runs the test under privnet with target logging severity. +mkPrivnetTestFor' :: TestName -> GYLogSeverity -> Setup -> (TestInfo -> GYTxGameMonadIO ()) -> TestTree +mkPrivnetTestFor' name targetSev setup action = testCaseSteps name $ \info -> withSetup' targetSev info setup $ \ctx -> do + ctxRunGame ctx $ action TestInfo { testGoldAsset = ctxGold ctx, testIronAsset = ctxIron ctx, testWallets = ctxWallets ctx } + {- TODO: WIP: Provide a variant of `withSetup` that can access `Ctx` to return a non-unit result. TODO: Can below implementation also accept @putLog@? @@ -172,7 +186,7 @@ withPrivnet testnetOpts setupUser = do -- Read pre-existing users. -- NOTE: As of writing, cardano-testnet creates three (3) users. - genesisUsers <- fmap V.fromList . liftIO . forM (zip [0 :: Int ..] runtimeWallets) + genesisUsers <- fmap V.fromList . liftIO . forM (zip [1 :: Int ..] runtimeWallets) $ \(idx, PaymentKeyInfo {paymentKeyInfoPair, paymentKeyInfoAddr}) -> do debug $ printf "userF = %s\n" (show idx) userAddr <- addressFromBech32 <$> urlPieceFromText paymentKeyInfoAddr @@ -247,17 +261,14 @@ withPrivnet testnetOpts setupUser = do , ctxGetParams = localGetParams } - userBalances <- V.mapM - (\(i, User'{userAddr=userIaddr}) -> do + V.imapM_ + (\i User'{userAddr=userIaddr} -> do userIbalance <- ctxRunQuery ctx0 $ queryBalance userIaddr when (isEmptyValue userIbalance) $ do - debug $ printf "User' %s balance is empty, giving some ada\n" (show i) + debug $ printf "User %d balance is empty, giving some ada\n" $ i + 1 giveAda ctx0 userIaddr when (i == 0) (giveAda ctx0 . userAddr $ ctxUserF ctx0) -- we also give ada to itself to create some small utxos - ctxRunQuery ctx0 $ queryBalance userIaddr - ) $ V.zip - (V.fromList extraIndices) - extraUsers + ) allUsers -- mint test tokens goldAC <- mintTestTokens ctx0 "GOLD" @@ -273,16 +284,14 @@ withPrivnet testnetOpts setupUser = do } -- distribute tokens - mapM_ - (\(i, userIbalance, user) -> do + V.imapM_ + (\i User'{userAddr=userIaddr} -> do + userIbalance <- ctxRunQuery ctx0 $ queryBalance userIaddr when (isEmptyValue $ snd $ valueSplitAda userIbalance) $ do - debug $ printf "User'%s has no tokens, giving some\n" (show i) - giveTokens ctx (userAddr user) + debug $ printf "User %d has no tokens, giving some\n" $ i + 1 + giveTokens ctx userIaddr ) - $ V.zip3 - (V.fromList extraIndices) - userBalances - extraUsers + allUsers let setup = Setup $ \targetSev putLog kont -> kont $ ctx { ctxLog = simpleLogging targetSev (putLog . Txt.unpack) } setupUser setup @@ -326,8 +335,8 @@ giveAda ctx addr = ctxRun ctx (ctxUserF ctx) $ do giveTokens :: Ctx -> GYAddress -> IO () giveTokens ctx addr = ctxRun ctx (ctxUserF ctx) $ do txBody <- buildTxBody $ - mustHaveOutput (mkGYTxOutNoDatum addr (valueSingleton (ctxGold ctx) 1_000_000)) <> - mustHaveOutput (mkGYTxOutNoDatum addr (valueSingleton (ctxIron ctx) 1_000_000)) + mustHaveOutput (mkGYTxOutNoDatum addr (valueSingleton (ctxGold ctx) 10_000_000)) <> + mustHaveOutput (mkGYTxOutNoDatum addr (valueSingleton (ctxIron ctx) 10_000_000)) signAndSubmitConfirmed_ txBody ------------------------------------------------------------------------------- @@ -337,7 +346,7 @@ giveTokens ctx addr = ctxRun ctx (ctxUserF ctx) $ do mintTestTokens :: Ctx -> String -> IO GYAssetClass mintTestTokens ctx tn' = do ctxRun ctx (ctxUserF ctx) $ do - (ac, txBody) <- GY.TestTokens.mintTestTokens tn 10_000_000 >>= traverse buildTxBody + (ac, txBody) <- GY.TestTokens.mintTestTokens tn 1_000_000_000 >>= traverse buildTxBody signAndSubmitConfirmed_ txBody pure ac where diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index 4a6bf59d..65e098aa 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -9,7 +9,8 @@ Stability : develop -} module GeniusYield.Test.Utils - ( Wallets (..) + ( TestInfo (..) + , Wallets (..) , withBalance , withWalletBalancesCheck , findLockedUtxosInBody @@ -97,6 +98,9 @@ fakeIron = fromFakeCoin $ FakeCoin "Iron" -- helpers ------------------------------------------------------------------------------- +-- | General information about the test environment to help in running polymorphic tests. +data TestInfo = TestInfo { testGoldAsset :: !GYAssetClass, testIronAsset :: !GYAssetClass, testWallets :: !Wallets } + -- | Available wallets. data Wallets = Wallets { w1 :: !User diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs index bc8761f1..fdee5751 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs @@ -20,7 +20,7 @@ betRefAddress :: (HasCallStack, GYTxQueryMonad m) => BetRefParams -> m GYAddress betRefAddress brp = scriptAddress $ betRefValidator' brp -- | Operation to place bet. -placeBet :: (HasCallStack, GYTxMonad m) +placeBet :: (HasCallStack, GYTxQueryMonad m) => GYTxOutRef -- ^ Reference Script. -> BetRefParams -- ^ Validator Params. -> OracleAnswerDatum -- ^ Guess. diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index 25dacfa7..a76f3900 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -4,7 +4,9 @@ module GeniusYield.Test.Unified.BetRef.PlaceBet , multipleBetsTraceCore ) where +import Control.Monad.Except (handleError) import qualified Data.Set as Set +import qualified Data.Text as T import Test.Tasty (TestTree, testGroup) @@ -12,49 +14,69 @@ import GeniusYield.Test.Unified.BetRef.Operations import GeniusYield.Test.Unified.OnChain.BetRef.Compiled import GeniusYield.Imports +import GeniusYield.HTTP.Errors import GeniusYield.Test.Clb +import GeniusYield.Test.Privnet.Setup import GeniusYield.Test.Utils import GeniusYield.TxBuilder import GeniusYield.Types -- | Our unit tests for placing bet operation -placeBetTests :: TestTree -placeBetTests = testGroup "Place Bet" - [ mkTestFor "Simple spending tx" simplSpendingTxTrace - , mkTestFor "Balance checks after placing first bet" $ - firstBetTrace (OracleAnswerDatum 3) (valueFromLovelace 20_000_000) - , mkTestFor "Balance checks with multiple bets" $ multipleBetsTraceWrapper 400 1_000 (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> fakeGold 1_000) - ] - , mkTestFor "Not adding atleast bet step amount should fail" $ mustFail . multipleBetsTraceWrapper 400 1_000 (valueFromLovelace 10_000_000) +placeBetTests :: Setup -> TestTree +placeBetTests setup = testGroup "Place Bet" + [ mkTestFor "Simple spending tx" $ simplSpendingTxTrace . testWallets + , mkPrivnetTestFor_ "Simple spending tx - privnet" $ simplSpendingTxTrace . testWallets + , mkTestFor "Balance checks after placing first bet" firstBetTest + , mkPrivnetTestFor_ "Balance checks after placing first bet - privnet" firstBetTest + , mkTestFor "Balance checks with multiple bets" multipleBetsTest + , mkPrivnetTestFor_ "Balance checks with multiple bets - privnet" multipleBetsTest + , mkTestFor "Not adding atleast bet step amount should fail" $ mustFail . failingMultipleBetsTest + , mkPrivnetTestFor' "Not adding atleast bet step amount should fail - privnet" GYDebug setup $ + handleError + (\case + GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () + e -> throwError e + ) + . failingMultipleBetsTest + ] + where + mkPrivnetTestFor_ = flip mkPrivnetTestFor setup + firstBetTest :: GYTxGameMonad m => TestInfo -> m () + firstBetTest = firstBetTrace (OracleAnswerDatum 3) (valueFromLovelace 20_000_000) . testWallets + multipleBetsTest :: GYTxGameMonad m => TestInfo -> m () + multipleBetsTest TestInfo{..} = multipleBetsTraceWrapper 400 1_000 (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 55_000_000 <> fakeGold 1_000)] - ] + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) + ] + testWallets + failingMultipleBetsTest :: GYTxGameMonad m => TestInfo -> m () + failingMultipleBetsTest TestInfo{..} = multipleBetsTraceWrapper 400 1_000 (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 55_000_000 <> valueSingleton testGoldAsset 1_000) + ] + testWallets -- ----------------------------------------------------------------------------- -- Super-trivial example -- ----------------------------------------------------------------------------- -- | Trace for a super-simple spending transaction. -simplSpendingTxTrace :: Wallets -> GYTxMonadClb () +simplSpendingTxTrace :: GYTxGameMonad m => Wallets -> m () simplSpendingTxTrace Wallets{w1} = do gyLogDebug' "" "Hey there!" -- balance assetion check - void . withWalletBalancesCheckSimple [w1 := valueFromLovelace (-100_000_000)] . asUser w1 $ do -- TODO: w1 is the wallets that gets all funds for now + withWalletBalancesCheckSimple [w1 := valueFromLovelace (-100_000_000)] . asUser w1 $ do -- TODO: w1 is the wallets that gets all funds for now skeleton <- mkTrivialTx gyLogDebug' "" $ printf "tx skeleton: %s" (show skeleton) - ftLift dumpUtxoState -- test itself txId <- buildTxBody skeleton >>= signAndSubmitConfirmed - ftLift dumpUtxoState gyLogDebug' "" $ printf "tx submitted, txId: %s" txId -- Pretend off-chain code written in 'GYTxMonad m' @@ -90,24 +112,28 @@ Level 3. The action (Off-chain code) -- ----------------------------------------------------------------------------- -- | Trace for placing the first bet. -firstBetTrace :: OracleAnswerDatum -- ^ Guess +firstBetTrace :: GYTxGameMonad m + => OracleAnswerDatum -- ^ Guess -> GYValue -- ^ Bet - -> Wallets -> GYTxMonadClb () -- Our continuation function + -> Wallets -> m () -- Our continuation function firstBetTrace dat bet ws@Wallets{w1} = do - + currSlot <- slotToInteger <$> slotOfCurrentBlock + let betUntil = currSlot + 40 + betReveal = currSlot + 100 -- First step: Get the required parameters for initializing our parameterized script, -- claculate the script, and post it to the blockchain as a reference script. - (brp, refScript) <- computeParamsAndAddRefScript 40 100 (valueFromLovelace 200_000_000) ws - void . withWalletBalancesCheckSimple [w1 := valueNegate bet] . asUser w1 $ do -- following operations are ran by first wallet, `w1` + (brp, refScript) <- computeParamsAndAddRefScript betUntil betReveal (valueFromLovelace 200_000_000) ws + withWalletBalancesCheckSimple [w1 := valueNegate bet] . asUser w1 $ do -- following operations are ran by first wallet, `w1` -- Second step: Perform the actual run. - placeBetRun refScript brp dat bet Nothing + void $ placeBetRun refScript brp dat bet Nothing -- | Function to compute the parameters for the contract and add the corresponding refernce script. computeParamsAndAddRefScript - :: Integer -- ^ Bet Until slot + :: GYTxGameMonad m + => Integer -- ^ Bet Until slot -> Integer -- ^ Bet Reveal slot -> GYValue -- ^ Bet step value - -> Wallets -> GYTxMonadClb (BetRefParams, GYTxOutRef) -- Our continuation + -> Wallets -> m (BetRefParams, GYTxOutRef) -- Our continuation computeParamsAndAddRefScript betUntil' betReveal' betStep Wallets{..} = do let betUntil = slotFromApi (fromInteger betUntil') betReveal = slotFromApi (fromInteger betReveal') @@ -146,23 +172,28 @@ placeBetRun refScript brp guess bet mPreviousBetsUtxoRef = do -- | Trace which allows for multiple bets. multipleBetsTraceWrapper - :: Integer -- ^ slot for betUntil + :: GYTxGameMonad m + => Integer -- ^ slot for betUntil -> Integer -- ^ slot for betReveal -> GYValue -- ^ bet step -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets - -> Wallets -> GYTxMonadClb () -- Our continuation function + -> Wallets -> m () -- Our continuation function multipleBetsTraceWrapper betUntil' betReveal' betStep walletBets ws = do + currSlot <- slotToInteger <$> slotOfCurrentBlock + let betUntil = currSlot + betUntil' + betReveal = currSlot + betReveal' -- First step: Get the required parameters for initializing our parameterized script and add the corresponding reference script - (brp, refScript) <- computeParamsAndAddRefScript betUntil' betReveal' betStep ws + (brp, refScript) <- computeParamsAndAddRefScript betUntil betReveal betStep ws -- Second step: Perform the actual bet operations multipleBetsTraceCore brp refScript walletBets ws -- | Trace which allows for multiple bets. multipleBetsTraceCore - :: BetRefParams + :: GYTxGameMonad m + => BetRefParams -> GYTxOutRef -- ^ Reference script -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets - -> Wallets -> GYTxMonadClb () -- Our continuation function + -> Wallets -> m () -- Our continuation function multipleBetsTraceCore brp refScript walletBets ws@Wallets{..} = do let -- | Perform the actual bet operation by the corresponding wallet. @@ -170,15 +201,15 @@ multipleBetsTraceCore brp refScript walletBets ws@Wallets{..} = do performBetOperations ((getWallet, dat, bet) : remWalletBets) isFirst = do if isFirst then do gyLogInfo' "" "placing the first bet" - void $ asUser (getWallet ws) $ do + asUser (getWallet ws) $ do void $ placeBetRun refScript brp dat bet Nothing performBetOperations remWalletBets False else do gyLogInfo' "" "placing a next bet" -- need to get previous bet utxo - void $ asUser (getWallet ws) $ do + asUser (getWallet ws) $ do betRefAddr <- betRefAddress brp - [_scriptUtxo@GYUTxO {utxoRef}] <- utxosToList <$> utxosAtAddress betRefAddr Nothing + _scriptUtxo@GYUTxO {utxoRef} <- head . utxosToList <$> utxosAtAddress betRefAddr Nothing gyLogDebug' "" $ printf "previous bet utxo: %s" utxoRef void $ placeBetRun refScript brp dat bet (Just utxoRef) performBetOperations remWalletBets False @@ -206,7 +237,7 @@ multipleBetsTraceCore brp refScript walletBets ws@Wallets{..} = do balanceAfterAllTheseOps <- asUser w1 $ traverse (\(wallet, _value) -> queryBalances $ userAddresses' wallet) balanceDiffWithoutFees gyLogDebug' "" $ printf "balanceAfterAllTheseOps: %s" (mconcat balanceAfterAllTheseOps) -- Check the difference - void $ asUser w1 $ verify (zip3 balanceDiffWithoutFees balanceBeforeAllTheseOps balanceAfterAllTheseOps) + asUser w1 $ verify (zip3 balanceDiffWithoutFees balanceBeforeAllTheseOps balanceAfterAllTheseOps) where -- | Function to verify that the wallet indeed lost by /roughly/ the bet amount. -- We say /roughly/ as fees is assumed to be within (0, 1 ada]. @@ -222,5 +253,5 @@ multipleBetsTraceCore brp refScript walletBets ws@Wallets{..} = do && expectedAdaWithoutFees - threshold <= actualAda then verify xs else - fail ("For wallet " <> show (userAddr wallet) <> " expected value (without fees) " <> - show vAfterWithoutFees <> " but actual is " <> show vAfter) \ No newline at end of file + throwAppError . someBackendError . T.pack $ ("For wallet " <> show (userAddr wallet) <> " expected value (without fees) " <> + show vAfterWithoutFees <> " but actual is " <> show vAfter) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs index d5d970c1..f687d495 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -2,6 +2,7 @@ module GeniusYield.Test.Unified.BetRef.TakePot ( takeBetPotTests ) where +import Control.Monad.Except (handleError) import Test.Tasty (TestTree, testGroup) import GeniusYield.Test.Unified.BetRef.Operations @@ -10,41 +11,58 @@ import GeniusYield.Test.Unified.BetRef.PlaceBet import GeniusYield.Imports import GeniusYield.Test.Clb +import GeniusYield.Test.Privnet.Setup import GeniusYield.Test.Utils import GeniusYield.TxBuilder import GeniusYield.Types -- | Our unit tests for taking the bet pot operation -takeBetPotTests :: TestTree -takeBetPotTests = testGroup "Take bet pot" - [ mkTestFor "Balance check after taking bet pot" $ takeBetsTrace 400 1_000 +takeBetPotTests :: Setup -> TestTree +takeBetPotTests setup = testGroup "Take bet pot" + [ mkTestFor "Balance check after taking bet pot" takeBetsTest + , mkPrivnetTestFor_ "Balance check after taking bet pot - privnet" takeBetsTest + , mkTestFor "Must fail if attempt to take is by wrong guesser" $ mustFail . wrongGuesserTakeBetsTest + , mkPrivnetTestFor_ "Must fail if attempt to take is by wrong guesser - privnet" $ mustFailPrivnet . wrongGuesserTakeBetsTest + , mkTestFor "Must fail even if old guess was closest but updated one is not" $ mustFail . badUpdatedGuessTakeBetsTest + , mkPrivnetTestFor_ "Must fail even if old guess was closest but updated one is not - privnet" $ mustFailPrivnet . badUpdatedGuessTakeBetsTest + ] + where + mkPrivnetTestFor_ = flip mkPrivnetTestFor setup + takeBetsTest :: GYTxGameMonad m => TestInfo -> m () + takeBetsTest TestInfo{..} = takeBetsTrace 400 1_000 (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> fakeGold 1_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) ] - 4 w2 - , mkTestFor "Must fail if attempt to take is by wrong guesser" $ mustFail . takeBetsTrace + 4 w2 testWallets + wrongGuesserTakeBetsTest :: GYTxGameMonad m => TestInfo -> m () + wrongGuesserTakeBetsTest TestInfo{..} = takeBetsTrace 400 1_000 (valueFromLovelace 10_000_000) [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> fakeGold 1_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) ] - 5 w2 - , mkTestFor "Must fail even if old guess was closest but updated one is not" $ - mustFail . takeBetsTrace 400 1_000 (valueFromLovelace 10_000_000) - [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) - , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) - , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) - , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) - , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> fakeGold 1_000) - ] - 2 w2 - ] + 5 w2 testWallets + badUpdatedGuessTakeBetsTest :: GYTxGameMonad m => TestInfo -> m () + badUpdatedGuessTakeBetsTest TestInfo{..} = takeBetsTrace 400 1_000 (valueFromLovelace 10_000_000) + [ (w1, OracleAnswerDatum 1, valueFromLovelace 10_000_000) + , (w2, OracleAnswerDatum 2, valueFromLovelace 20_000_000) + , (w3, OracleAnswerDatum 3, valueFromLovelace 30_000_000) + , (w2, OracleAnswerDatum 4, valueFromLovelace 50_000_000) + , (w4, OracleAnswerDatum 5, valueFromLovelace 65_000_000 <> valueSingleton testGoldAsset 1_000) + ] + 2 w2 testWallets + -- Must fail with script execution error (which is fired in the body error auto balance). + mustFailPrivnet = handleError + (\case + GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () + e -> throwError e + ) -- | Run to call the `takeBets` operation. takeBetsRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> GYTxOutRef -> GYTxOutRef -> m GYTxId @@ -54,24 +72,25 @@ takeBetsRun refScript brp toConsume refInput = do buildTxBody skeleton >>= signAndSubmitConfirmed -- | Trace for taking bet pot. -takeBetsTrace :: Integer -- ^ slot for betUntil +takeBetsTrace :: GYTxGameMonad m + => Integer -- ^ slot for betUntil -> Integer -- ^ slot for betReveal -> GYValue -- ^ bet step -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets -> Integer -- ^ Actual answer -> (Wallets -> User) -- ^ Taker - -> Wallets -> GYTxMonadClb () -- Our continuation function + -> Wallets -> m () -- Our continuation function takeBetsTrace betUntil' betReveal' betStep walletBets answer getTaker ws@Wallets{..} = do - (brp, refScript) <- computeParamsAndAddRefScript betUntil' betReveal' betStep ws + currSlot <- slotToInteger <$> slotOfCurrentBlock + let betUntil = currSlot + betUntil' + betReveal = currSlot + betReveal' + (brp, refScript) <- computeParamsAndAddRefScript betUntil betReveal betStep ws multipleBetsTraceCore brp refScript walletBets ws -- Now lets take the bet - ref <- asUser w1 $ addRefInput True (userAddr w8) (datumFromPlutusData $ OracleAnswerDatum answer) + refInput <- asUser w1 $ addRefInput True (userAddr w8) (datumFromPlutusData $ OracleAnswerDatum answer) let taker = getTaker ws - case ref of - Just refInput -> do - betRefAddr <- betRefAddress brp - [_scriptUtxo@GYUTxO {utxoRef, utxoValue}] <- utxosToList <$> utxosAtAddress betRefAddr Nothing - waitUntilSlot_ $ slotFromApi (fromInteger betReveal') - void . withWalletBalancesCheckSimple [taker := utxoValue] . asUser taker - $ takeBetsRun refScript brp utxoRef refInput - _ -> fail "Couldn't place reference input successfully" + betRefAddr <- betRefAddress brp + _scriptUtxo@GYUTxO {utxoRef, utxoValue} <- head . utxosToList <$> utxosAtAddress betRefAddr Nothing + waitUntilSlot_ $ slotFromApi (fromInteger betReveal) + withWalletBalancesCheckSimple [taker := utxoValue] . asUser taker + . void $ takeBetsRun refScript brp utxoRef refInput diff --git a/tests-unified/atlas-unified-tests.hs b/tests-unified/atlas-unified-tests.hs index a0c6d6fd..21f2ef09 100644 --- a/tests-unified/atlas-unified-tests.hs +++ b/tests-unified/atlas-unified-tests.hs @@ -4,8 +4,11 @@ module Main import Test.Tasty (defaultMain, testGroup) +import GeniusYield.Test.Privnet.Setup + import GeniusYield.Test.Unified.BetRef.PlaceBet import GeniusYield.Test.Unified.BetRef.TakePot main :: IO () -main = defaultMain $ testGroup "BetRef" [placeBetTests, takeBetPotTests] \ No newline at end of file +main = withPrivnet cardanoDefaultTestnetOptions $ \setup -> + defaultMain $ testGroup "BetRef" [placeBetTests setup, takeBetPotTests setup] diff --git a/tests/GeniusYield/Test/RefInput.hs b/tests/GeniusYield/Test/RefInput.hs index 0a786ca9..9c929cc5 100644 --- a/tests/GeniusYield/Test/RefInput.hs +++ b/tests/GeniusYield/Test/RefInput.hs @@ -30,11 +30,12 @@ gyGuessRefInputDatumValidator = validatorFromPlutus guessRefInputDatumValidator refInputTests :: TestTree refInputTests = testGroup "Reference Input" - [ mkTestFor "Inlined datum" $ refInputTrace True 5 5 - , mkTestFor "Inlined datum - Wrong guess" $ mustFail . refInputTrace True 5 4 + [ mkTestFor "Inlined datum" $ refInputTrace True 5 5 . testWallets + , mkTestFor "Inlined datum - Wrong guess" $ mustFail . refInputTrace True 5 4 . testWallets , mkTestFor "Reference input must not be consumed" $ mustFailWith (\case { GYBuildTxException (GYBuildTxBalancingError (GYBalancingErrorInsufficientFunds _)) -> True; _ -> False }) . tryRefInputConsume + . testWallets ] guessRefInputRun :: GYTxMonad m => GYTxOutRef -> GYTxOutRef -> Integer -> m ()