diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index d6d47d1e..c2e08680 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -84,11 +84,13 @@ library GeniusYield.ReadJSON GeniusYield.Scripts.TestToken GeniusYield.Swagger.Utils - GeniusYield.Test.Address + GeniusYield.Test.Clb GeniusYield.Test.FakeCoin + GeniusYield.Test.FeeTracker 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 @@ -103,7 +105,6 @@ library GeniusYield.Transaction.Common GeniusYield.TxBuilder GeniusYield.TxBuilder.Class - GeniusYield.TxBuilder.Clb GeniusYield.TxBuilder.Common GeniusYield.TxBuilder.Errors GeniusYield.TxBuilder.IO @@ -352,3 +353,32 @@ 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 + , text + , mtl + -- OnChain + , plutus-core + , plutus-ledger-api + , plutus-tx + , plutus-tx-plugin 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/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 59% rename from src/GeniusYield/TxBuilder/Clb.hs rename to src/GeniusYield/Test/Clb.hs index 39489f66..be23c483 100644 --- a/src/GeniusYield/TxBuilder/Clb.hs +++ b/src/GeniusYield/Test/Clb.hs @@ -1,29 +1,22 @@ {-# 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 - ( Wallet (..) - , WalletName - , GYTxRunState (..) - , GYTxMonadClb - , walletAddress +module GeniusYield.Test.Clb + ( GYTxMonadClb + , mkTestFor , asClb , asRandClb , liftClb - , ownAddress - , sendSkeleton - , sendSkeleton' - , sendSkeletonWithWallets , dumpUtxoState , mustFail - , getNetworkId + , mustFailWith ) where import Control.Lens ((^.)) @@ -31,18 +24,14 @@ 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)) 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 @@ -59,59 +48,43 @@ 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) -import qualified Clb (dumpUtxoState) + txOutRefAtPaymentCred, sendTx, unLog, getFails, + logInfo, logError, waitSlot) +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.Transaction (GYBuildTxError (GYBuildTxBalancingError), - GYBalancingError(GYBalancingErrorInsufficientFunds)) -import GeniusYield.Transaction.Common (adjustTxOut, - minimumUTxO) -import GeniusYield.Test.Address 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 -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 - -instance HasAddress Wallet where - toAddress = addressToPlutus . walletAddress - -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 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 @@ -119,83 +92,125 @@ 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 + Left 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 + +{- | Given a test name, runs the trace for every wallet, checking there weren't + errors. +-} +mkTestFor :: String -> (TestInfo -> GYTxMonadClb a) -> Tasty.TestTree +mkTestFor name action = + testNoErrorsTraceClb v w Clb.defaultBabbage name $ do + 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 <> + fakeIron 1_000_000_000 + + w = valueFromLovelace 1_000_000_000_000 <> + fakeGold 1_000_000 <> + fakeIron 1_000_000 + + testWallets :: Wallets + testWallets = 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' 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 - 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 - 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 @@ -291,13 +306,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 @@ -316,94 +334,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 -> throwAppError . someBackendError . T.pack $ 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 @@ -422,7 +407,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 @@ -489,3 +473,10 @@ instance GYTxSpecialQueryMonad GYTxMonadClb where dumpUtxoState :: GYTxMonadClb () dumpUtxoState = liftClb Clb.dumpUtxoState +------------------------------------------------------------------------------- +-- Preset StdGen +------------------------------------------------------------------------------- + +pureGen :: StdGen +pureGen = mkStdGen 42 + diff --git a/src/GeniusYield/Test/FeeTracker.hs b/src/GeniusYield/Test/FeeTracker.hs new file mode 100644 index 00000000..a2cf4218 --- /dev/null +++ b/src/GeniusYield/Test/FeeTracker.hs @@ -0,0 +1,229 @@ +{-| +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, + ftgLift, + ftLift, + 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) + +-- | 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 + +-- | 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 + +-- | 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 + +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/Test/Privnet/Ctx.hs b/src/GeniusYield/Test/Privnet/Ctx.hs index a93c95e9..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, @@ -34,20 +36,15 @@ 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 import GeniusYield.Types +import GeniusYield.Test.Utils import Test.Tasty.HUnit (assertFailure) data CreateUserConfig = @@ -92,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. @@ -123,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 @@ -182,43 +194,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..96559258 100644 --- a/src/GeniusYield/Test/Privnet/Examples/Gift.hs +++ b/src/GeniusYield/Test/Privnet/Examples/Gift.hs @@ -10,34 +10,31 @@ 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 -import GeniusYield.Imports -import GeniusYield.Transaction -import GeniusYield.Types +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.Default (Default (def)) +import Data.Maybe (fromJust) +import Data.Ratio ((%)) +import qualified Data.Set as Set -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.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 _)) @@ -284,9 +281,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 +306,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 +355,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 +405,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 +645,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 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 23ec290b..65e098aa 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -9,22 +9,13 @@ Stability : develop -} module GeniusYield.Test.Utils - ( Clb.Clb - , mkTestFor + ( TestInfo (..) , Wallets (..) - , runWallet - , runWallet' - , walletAddress - , walletPubKeyHash - , balance , withBalance , withWalletBalancesCheck - , withWalletBalancesCheckSimple - , withWalletBalancesCheckSimpleIgnoreMinDepFor - , getBalance - , getBalances , findLockedUtxosInBody - , utxosInBody + , getRefInfos + , findRefScriptsInBody , addRefScript , addRefInput , fakeCoin, fakeGold, fakeIron @@ -32,60 +23,28 @@ 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 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) -import qualified PlutusLedgerApi.V1.Value as Plutus -import qualified PlutusLedgerApi.V2 as PlutusV2 +import qualified Data.Text as T -import qualified Test.Cardano.Ledger.Core.KeyPair as TL +import qualified PlutusLedgerApi.V1.Value as Plutus 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 +import GeniusYield.HTTP.Errors import GeniusYield.Imports -import GeniusYield.Test.Address import GeniusYield.Test.FakeCoin import GeniusYield.TxBuilder -import GeniusYield.TxBuilder.Clb import GeniusYield.Types +import GeniusYield.Test.FeeTracker as X + ------------------------------------------------------------------------------- -- tasty tools ------------------------------------------------------------------------------- @@ -139,237 +98,127 @@ 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 "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)) - - -- | 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 :: WalletName -> TL.KeyPair r L.StandardCrypto -> Wallet - mkSimpleWallet n kp = - Wallet - { walletPaymentSigningKey = paymentSigningKeyFromLedgerKeyPair kp - , walletNetworkId = GYTestnetPreprod - , walletName = n - } +-- | 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 :: !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 :: HasAddress a => a -> 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 - -{- | 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 :: HasAddress a => String -> a -> GYTxMonadClb b -> GYTxMonadClb (b, GYValue) +withBalance :: GYTxQueryMonad m => String -> User -> m b -> m (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) -{- | 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 :: [(Wallet, 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 (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 + 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 -{- | 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 + 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, []) --- | 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 + ] +-- | Find reference scripts in transaction body. +findRefScriptsInBody :: GYTxBody -> Map (Some GYScript) GYTxOutRef +findRefScriptsInBody body = do + let utxo = txBodyUTxOs body + utxoToRefMap 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' }) [] - - 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 +-- 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 + 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 + absurdError = someBackendError "Shouldn't happen: no ref in body" -- | 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 toInline addr dat = do - (tx, txId) <- sendSkeleton' - (mustHaveOutput +addRefInput :: GYTxMonad m + => Bool -- ^ Whether to inline this datum? + -> GYAddress -- ^ Where to place this output? + -> GYDatum -- ^ Our datum. + -> 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 - ) - [] - - outputsWithResolvedDatums <- mapM - (\o -> - resolveDatumFromLedger $ 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 - --- TODO: Add to CLB upstream? -getTxOutputs :: Clb.OnChainTx -> [L.B.BabbageTxOut (L.BabbageEra L.StandardCrypto)] -getTxOutputs = fmap L.sizedValue - . toList - . StrictSeq.fromStrict - . L.B.btbOutputs - . L.B.body - . L.S.extractTx - . Clb.getOnChainTx + + 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 + ) + $ 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. @@ -387,17 +236,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/src/GeniusYield/TxBuilder/Class.hs b/src/GeniusYield/TxBuilder/Class.hs index b59c5bc3..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 @@ -344,7 +354,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. 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 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' 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..fdee5751 --- /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, GYTxQueryMonad 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..a76f3900 --- /dev/null +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -0,0 +1,257 @@ +module GeniusYield.Test.Unified.BetRef.PlaceBet + ( placeBetTests + , computeParamsAndAddRefScript + , multipleBetsTraceCore + ) where + +import Control.Monad.Except (handleError) +import qualified Data.Set as Set +import qualified Data.Text as T +import Test.Tasty (TestTree, testGroup) + + +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 :: 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 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 :: GYTxGameMonad m => Wallets -> m () +simplSpendingTxTrace Wallets{w1} = do + gyLogDebug' "" "Hey there!" + -- balance assetion check + 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) + + -- test itself + txId <- buildTxBody skeleton >>= signAndSubmitConfirmed + 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 :: GYTxGameMonad m + => OracleAnswerDatum -- ^ Guess + -> GYValue -- ^ Bet + -> 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 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. + void $ placeBetRun refScript brp dat bet Nothing + +-- | Function to compute the parameters for the contract and add the corresponding refernce script. +computeParamsAndAddRefScript + :: GYTxGameMonad m + => Integer -- ^ Bet Until slot + -> Integer -- ^ Bet Reveal slot + -> GYValue -- ^ Bet step value + -> Wallets -> m (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 + :: GYTxGameMonad m + => Integer -- ^ slot for betUntil + -> Integer -- ^ slot for betReveal + -> GYValue -- ^ bet step + -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets + -> 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 + -- Second step: Perform the actual bet operations + multipleBetsTraceCore brp refScript walletBets ws + +-- | Trace which allows for multiple bets. +multipleBetsTraceCore + :: GYTxGameMonad m + => BetRefParams + -> GYTxOutRef -- ^ Reference script + -> [(Wallets -> User, OracleAnswerDatum, GYValue)] -- ^ List denoting the bets + -> Wallets -> m () -- 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" + 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 + asUser (getWallet ws) $ do + betRefAddr <- betRefAddress brp + _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 + + -- | 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 + 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 + 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 new file mode 100644 index 00000000..f687d495 --- /dev/null +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -0,0 +1,96 @@ +module GeniusYield.Test.Unified.BetRef.TakePot + ( takeBetPotTests + ) where + +import Control.Monad.Except (handleError) +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.Privnet.Setup +import GeniusYield.Test.Utils +import GeniusYield.TxBuilder +import GeniusYield.Types + +-- | Our unit tests for taking the bet pot operation +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 <> valueSingleton testGoldAsset 1_000) + ] + 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 <> valueSingleton testGoldAsset 1_000) + ] + 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 +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 :: 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 -> m () -- Our continuation function +takeBetsTrace betUntil' betReveal' betStep walletBets answer getTaker ws@Wallets{..} = do + 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 + refInput <- asUser w1 $ addRefInput True (userAddr w8) (datumFromPlutusData $ OracleAnswerDatum answer) + let taker = getTaker ws + 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/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..21f2ef09 --- /dev/null +++ b/tests-unified/atlas-unified-tests.hs @@ -0,0 +1,14 @@ +module Main + ( main + ) where + +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 = 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 674204a8..9c929cc5 100644 --- a/tests/GeniusYield/Test/RefInput.hs +++ b/tests/GeniusYield/Test/RefInput.hs @@ -17,11 +17,12 @@ import Test.Tasty (TestTree, testGroup) import GeniusYield.Imports -import GeniusYield.Test.GYTxBody (mockTxId) +import GeniusYield.HTTP.Errors +import GeniusYield.Test.Clb import GeniusYield.Test.OnChain.GuessRefInputDatum.Compiled import GeniusYield.Test.Utils +import GeniusYield.Transaction import GeniusYield.TxBuilder -import GeniusYield.TxBuilder.Clb import GeniusYield.Types gyGuessRefInputDatumValidator :: GYValidator 'PlutusV2 @@ -29,12 +30,15 @@ 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 "Reference input must not be consumed" tryRefInputConsume + [ 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 :: 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,40 @@ 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)) - 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 - addr <- scriptAddress gyGuessRefInputDatumValidator - (tx, txId) <- sendSkeleton' (mustHaveOutput $ mkGYTxOut addr outValue (datumFromPlutusData ())) [] - let mOrefIndices = findLockedUtxosInBody addr tx - orefIndices <- maybe (fail "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 - 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 :: 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 + 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_