diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index c2e08680..5d6f0071 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -373,6 +373,7 @@ test-suite atlas-unified-tests , atlas-cardano , base , containers + , extra , tasty , tasty-hunit , text diff --git a/src/GeniusYield/Test/Privnet/Setup.hs b/src/GeniusYield/Test/Privnet/Setup.hs index 9122f29a..ddaa0016 100644 --- a/src/GeniusYield/Test/Privnet/Setup.hs +++ b/src/GeniusYield/Test/Privnet/Setup.hs @@ -89,7 +89,7 @@ withSetup' targetSev putLog (Setup cokont) kont = do -- | Given a test name, runs the test under privnet. mkPrivnetTestFor :: TestName -> Setup -> (TestInfo -> GYTxGameMonadIO ()) -> TestTree -mkPrivnetTestFor name = mkPrivnetTestFor' name GYInfo +mkPrivnetTestFor name = mkPrivnetTestFor' name GYDebug -- | Given a test name, runs the test under privnet with target logging severity. mkPrivnetTestFor' :: TestName -> GYLogSeverity -> Setup -> (TestInfo -> GYTxGameMonadIO ()) -> TestTree diff --git a/src/GeniusYield/Test/Utils.hs b/src/GeniusYield/Test/Utils.hs index 65e098aa..8122ef62 100644 --- a/src/GeniusYield/Test/Utils.hs +++ b/src/GeniusYield/Test/Utils.hs @@ -99,7 +99,10 @@ fakeIron = fromFakeCoin $ FakeCoin "Iron" ------------------------------------------------------------------------------- -- | General information about the test environment to help in running polymorphic tests. -data TestInfo = TestInfo { testGoldAsset :: !GYAssetClass, testIronAsset :: !GYAssetClass, testWallets :: !Wallets } +data TestInfo = TestInfo + { testGoldAsset :: !GYAssetClass + , testIronAsset :: !GYAssetClass + , testWallets :: !Wallets } -- | Available wallets. data Wallets = Wallets diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs index fdee5751..b002d235 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs @@ -1,5 +1,6 @@ module GeniusYield.Test.Unified.BetRef.Operations - ( betRefValidator' + ( mkScript + , mkBetRefValidator , betRefAddress , placeBet , takeBets @@ -11,13 +12,37 @@ import GeniusYield.Types import GeniusYield.Test.Unified.OnChain.BetRef.Compiled +-- | Queries the cuurent slot, calculates parameters and builds +-- a script that is ready to be deployed. +mkScript + :: GYTxQueryMonad m + => Integer -- ^ How many slots betting should be open + -> Integer -- ^ How many slots should pass before oracle reveals answer + -> GYPubKeyHash -- ^ Oracle PKH + -> GYValue -- ^ Bet step value + -> m (BetRefParams, GYScript PlutusV2) +mkScript betUntil betReveal oraclePkh betStep = do + currSlot <- slotToInteger <$> slotOfCurrentBlock + -- Calculate params for the script + let betUntil' = slotFromApi $ fromInteger $ currSlot + betUntil + let betReveal' = slotFromApi $ fromInteger $ currSlot + betReveal + betUntilTime <- slotToBeginTime betUntil' + betRevealTime <- slotToBeginTime betReveal' + let params = BetRefParams + (pubKeyHashToPlutus oraclePkh) + (timeToPlutus betUntilTime) + (timeToPlutus betRevealTime) + (valueToPlutus betStep) + gyLogDebug' "" $ printf "Parameters: %s" (show params) + pure (params, validatorToScript $ mkBetRefValidator params) + -- | Validator in question, obtained after giving required parameters. -betRefValidator' :: BetRefParams -> GYValidator 'PlutusV2 -betRefValidator' brp = validatorFromPlutus $ betRefValidator brp +mkBetRefValidator :: BetRefParams -> GYValidator 'PlutusV2 +mkBetRefValidator brp = validatorFromPlutus $ betRefValidator brp -- | Address of the validator, given params. betRefAddress :: (HasCallStack, GYTxQueryMonad m) => BetRefParams -> m GYAddress -betRefAddress brp = scriptAddress $ betRefValidator' brp +betRefAddress brp = scriptAddress $ mkBetRefValidator brp -- | Operation to place bet. placeBet :: (HasCallStack, GYTxQueryMonad m) @@ -66,7 +91,7 @@ placeBet refScript brp guess bet ownAddr mPreviousBetsUtxoRef = do <> mustBeSignedBy pkh -- | Operation to take UTxO corresponding to previous bets. -takeBets :: (HasCallStack, GYTxMonad m) +takeBets :: (HasCallStack, GYTxQueryMonad m) => GYTxOutRef -- ^ Reference Script. -> BetRefParams -- ^ Validator params. -> GYTxOutRef -- ^ Script UTxO to consume. @@ -89,9 +114,8 @@ input :: BetRefParams -> GYTxOutRef -> GYTxOutRef -> BetRefDatum -> BetRefAction input brp refScript inputRef dat red = mustHaveInput GYTxIn { gyTxInTxOutRef = inputRef - -- , gyTxInWitness = GYTxInWitnessKey , gyTxInWitness = GYTxInWitnessScript - (GYInReference refScript $ validatorToScript $ betRefValidator' brp) + (GYInReference refScript $ validatorToScript $ mkBetRefValidator 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 index a76f3900..6dbea9b9 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -1,18 +1,19 @@ module GeniusYield.Test.Unified.BetRef.PlaceBet ( placeBetTests - , computeParamsAndAddRefScript - , multipleBetsTraceCore + , placeBetTestsClb + , runDeployScript + , runMultipleBets ) where -import Control.Monad.Except (handleError) -import qualified Data.Set as Set -import qualified Data.Text as T -import Test.Tasty (TestTree, testGroup) - +import Control.Monad.Except (handleError) +import Control.Monad.Extra (maybeM) +import Data.Maybe (listToMaybe) +import qualified Data.Set as Set +import Test.Tasty (TestTree, testGroup) +import qualified Data.Text as T import GeniusYield.Test.Unified.BetRef.Operations import GeniusYield.Test.Unified.OnChain.BetRef.Compiled - import GeniusYield.Imports import GeniusYield.HTTP.Errors import GeniusYield.Test.Clb @@ -21,17 +22,30 @@ import GeniusYield.Test.Utils import GeniusYield.TxBuilder import GeniusYield.Types --- | Our unit tests for placing bet operation + +-- | Test environment 'WalletInfo' among other things provides nine wallets that +-- be used in tests. For convinience we assign some meaningful names to them. +admin, oracle, holder :: Wallets -> User +admin = w1 -- Runs some administrative action, e.g. deplys the script +oracle = w8 -- A user that is going to reveal the answer +holder = w9 -- A user to store the reference script + +-- | Test suite for the emulator +placeBetTestsClb :: TestTree +placeBetTestsClb = testGroup "Place bet" + [ mkTestFor "Simple tx" $ simpleTxTest + , mkTestFor "Placing first bet" firstBetTest' + , mkTestFor "Multiple bets" multipleBetsTest + , mkTestFor "Multiple bets - to small step" $ mustFail . failingMultipleBetsTest + ] + +-- | Test suite for a private testnet 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 $ +placeBetTests setup = testGroup "Place bet" + [ mkPrivnetTestFor_ "Simple tx" $ simpleTxTest + , mkPrivnetTestFor_ "Placing first bet" firstBetTest' + , mkPrivnetTestFor_ "Multiple bets" multipleBetsTest + , mkPrivnetTestFor' "Multiple bets - too small step" GYDebug setup $ handleError (\case GYBuildTxException GYBuildTxBodyErrorAutoBalance {} -> pure () @@ -41,52 +55,30 @@ placeBetTests setup = testGroup "Place Bet" ] 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 +-- Simple tx -- ----------------------------------------------------------------------------- --- | 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 +-- | Trace for a super-simple spending transaction. This function combines +-- the runner and the test for simplicity's sake. +simpleTxTest :: GYTxGameMonad m => TestInfo -> m () +simpleTxTest (testWallets -> Wallets{w1}) = do + withWalletBalancesCheckSimple [w1 := valueFromLovelace (-100_000_000)] . + asUser w1 $ do 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: + addr <- maybeM (throwAppError $ someBackendError "No own addresses") + pure $ listToMaybe <$> ownAddresses gyLogDebug' "" $ printf "ownAddr: %s" (show addr) pkh <- addressToPubKeyHash' addr let targetAddr = unsafeAddressFromText "addr_test1qr2vfntpz92f9pawk8gs0fdmhtfe32pqcx0s8fuztxaw3p5pjay24kygaj4g8uevf89ewxzvsdc60wln8spzm2al059q8a9w3x" - -- let targetAddr = unsafeAddressFromText "addr1q82vfntpz92f9pawk8gs0fdmhtfe32pqcx0s8fuztxaw3p5pjay24kygaj4g8uevf89ewxzvsdc60wln8spzm2al059qytcwae" return $ mustHaveOutput (GYTxOut @@ -97,150 +89,154 @@ mkTrivialTx = do }) <> 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 +-- First bet -- ----------------------------------------------------------------------------- --- | 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 +-- | Run to call the `placeBet` operation. +runPlaceBet :: 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 + => GYTxOutRef -- ^ Script output reference + -> BetRefParams -- ^ Parameters + -> OracleAnswerDatum -- ^ Bet guess + -> GYValue -- ^ Bet value + -> Maybe GYTxOutRef -- ^ Ref output with existing bets + -> User -- ^ User that plays bet + -> m GYTxId +runPlaceBet refScript brp guess bet mPrevBets user = do + gyLogDebug' "" + $ printf "placing a bet with guess %s and value %s" + (show guess) (show bet) + asUser user $ do + addr <- maybeM (throwAppError $ someBackendError "No own addresses") + pure $ listToMaybe <$> ownAddresses + -- Call the operation + skeleton <- placeBet refScript brp guess bet addr mPrevBets + buildTxBody skeleton >>= signAndSubmitConfirmed - let brp = BetRefParams - (pubKeyHashToPlutus $ userPkh w8) -- let oracle be wallet `w8` - (timeToPlutus betUntilTime) - (timeToPlutus betRevealTime) - (valueToPlutus betStep) +firstBetTest' :: GYTxGameMonad m => TestInfo -> m () +firstBetTest' = firstBetTest + 40 + 100 + (valueFromLovelace 200_000_000) + (OracleAnswerDatum 3) + (valueFromLovelace 20_000_000) - -- 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 +-- | Test for placing the first bet. +firstBetTest + :: GYTxGameMonad m + => Integer + -> Integer + -> GYValue + -> OracleAnswerDatum + -> GYValue + -> TestInfo + -> m () +firstBetTest betUntil betReveal betStep dat bet (testWallets -> ws@Wallets{w1}) = do + (brp, refScript) <- runDeployScript betUntil betReveal betStep ws + withWalletBalancesCheckSimple [w1 := valueNegate bet] $ do + void $ runPlaceBet refScript brp dat bet Nothing w1 -- ----------------------------------------------------------------------------- --- Multiple bets example +-- Multiple bets -- ----------------------------------------------------------------------------- --- | 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 +-- This is an alias for fields of `Wallet` datatype +type Wallet = Wallets -> User - -- | 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. +-- This type represent a bet made by a wallet +type Bet = (Wallet, OracleAnswerDatum, GYValue) - 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) +multipleBetsTest :: GYTxGameMonad m => TestInfo -> m () +multipleBetsTest TestInfo{..} = mkMultipleBetsTest + 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 - balanceDiffWithoutFees = getBalanceDiff walletBets Set.empty [] +failingMultipleBetsTest :: GYTxGameMonad m => TestInfo -> m () +failingMultipleBetsTest TestInfo{..} = mkMultipleBetsTest + 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 - -- 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) +-- | Makes a test case for placing multiple bets. +mkMultipleBetsTest + :: GYTxGameMonad m + => Integer -- ^ Number of slots for betting + -> Integer -- ^ Number of slots for revealing + -> GYValue -- ^ Bet step + -> [Bet] -- ^ List denoting the bets + -> Wallets -- ^ Wallets available + -> m () +mkMultipleBetsTest betUntil betReveal betStep bets ws = do + -- Deploy script + (brp, refScript) <- runDeployScript betUntil betReveal betStep ws + -- Get the balance + balanceBefore <- getBalance + gyLogDebug' "" $ printf "balanceBeforeAllTheseOps: %s" (mconcat balanceBefore) + -- Run operations + runMultipleBets brp refScript bets ws + -- Get the balance again + balanceAfter <- getBalance + gyLogDebug' "" $ printf "balanceAfterAllTheseOps: %s" (mconcat balanceAfter) -- Check the difference - asUser w1 $ verify (zip3 balanceDiffWithoutFees balanceBeforeAllTheseOps balanceAfterAllTheseOps) + verify $ zip3 + walletsAndBets + balanceBefore + balanceAfter where + -- | Returns the balances for all wallets that play the game + getBalance :: GYTxGameMonad m => m [GYValue] + getBalance = traverse + (\(wallet, _) -> queryBalances $ userAddresses' wallet) + walletsAndBets + + -- | Builds the list of wallets and their respective bets made. + -- The idea here is that if we encounter a new wallet, + -- i.e., wallet for whose we haven't yet computed value lost, + -- we calculate the total once so we can ignore other entries + -- for this wallet. + -- FIXME: very ineffective, can be simplified drastically. + walletsAndBets :: [(User, GYValue)] + walletsAndBets = go bets Set.empty [] + where + go [] _ acc = acc + go allBets@((getWallet, _, _) : remBets) set acc = + let wallet = getWallet ws + addr = userAddr wallet + in + if Set.member addr set + then go remBets set acc -- already summed + else go + remBets + (Set.insert addr set) + ((wallet := totalBets wallet allBets mempty) : acc) + + -- | Recursive functions that sums all bets for the corresponding wallet. + totalBets :: User -> [Bet] -> GYValue -> GYValue + totalBets _ [] acc = acc + totalBets wallet ((getWallet, _, bet) : remBets) acc = + totalBets wallet remBets $ + if getWallet ws == wallet + then acc <> valueNegate bet + else acc + + -- | 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 :: GYTxGameMonad m => [((User, GYValue), GYValue, GYValue)] -> m () verify [] = return () verify (((wallet, diff), vBefore, vAfter) : xs) = let vAfterWithoutFees = vBefore <> diff @@ -253,5 +249,54 @@ multipleBetsTraceCore brp refScript walletBets ws@Wallets{..} = do && 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) + throwAppError . someBackendError . T.pack $ + printf "For wallet %s expected value (without fees) %s but actual is %s" + (show $ userAddr wallet) + (show vAfterWithoutFees) + (show vAfter) + +-- | Runner for multiple bets. +runMultipleBets + :: GYTxGameMonad m + => BetRefParams + -> GYTxOutRef -- ^ Reference script + -> [Bet] + -> Wallets + -> m () +runMultipleBets brp refScript bets ws = go bets True + where + go [] _ = return () + go ((getWallet, dat, bet) : remBets) isFirst = do + if isFirst then do + gyLogInfo' "" "placing the first bet" + void $ runPlaceBet refScript brp dat bet Nothing (getWallet ws) + go remBets False + else do + gyLogInfo' "" "placing a next bet" + -- need to get previous bet utxo + betRefAddr <- betRefAddress brp + GYUTxO{utxoRef} <- head . utxosToList <$> utxosAtAddress betRefAddr Nothing + gyLogDebug' "" $ printf "previous bet utxo: %s" utxoRef + void $ runPlaceBet refScript brp dat bet (Just utxoRef) (getWallet ws) + go remBets False + +-- ----------------------------------------------------------------------------- +-- Auxiliary runners +-- ----------------------------------------------------------------------------- + +-- | Runner to build and submit a transaction that deploys the reference script. +runDeployScript + :: GYTxGameMonad m + => Integer -- ^ Bet Until slot + -> Integer -- ^ Bet Reveal slot + -> GYValue -- ^ Bet step value + -> Wallets + -> m (BetRefParams, GYTxOutRef) +runDeployScript betUntil betReveal betStep ws = do + (params, script) <- mkScript betUntil betReveal (userPkh $ oracle ws) betStep + asUser (admin ws) $ do + let sAddr = userAddr (holder ws) + gyLogDebug' "" $ printf "Ref script storage addr: %s" (show sAddr) + refScript <- addRefScript sAddr script + gyLogDebug' "" $ printf "Ref script deployed, ref output is: %s" (show refScript) + pure (params, refScript) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs index f687d495..1badd3a4 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -1,5 +1,6 @@ module GeniusYield.Test.Unified.BetRef.TakePot ( takeBetPotTests + , takeBetPotTestsClb ) where import Control.Monad.Except (handleError) @@ -16,47 +17,22 @@ import GeniusYield.Test.Utils import GeniusYield.TxBuilder import GeniusYield.Types +takeBetPotTestsClb :: TestTree +takeBetPotTestsClb = testGroup "Take bet pot" + [ mkTestFor "Balance check after taking bet pot" takeBetsTest + , mkTestFor "Must fail if attempt to take is by wrong guesser" $ mustFail . wrongGuesserTakeBetsTest + , mkTestFor "Must fail even if old guess was closest but updated one is not" $ mustFail . badUpdatedGuessTakeBetsTest + ] + -- | 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_ "Balance check after taking bet pot - privnet" takeBetsTest , 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 @@ -64,6 +40,38 @@ takeBetPotTests setup = testGroup "Take bet pot" e -> throwError e ) +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 + -- | Run to call the `takeBets` operation. takeBetsRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> GYTxOutRef -> GYTxOutRef -> m GYTxId takeBetsRun refScript brp toConsume refInput = do @@ -84,13 +92,14 @@ takeBetsTrace betUntil' betReveal' betStep walletBets answer getTaker ws@Wallets 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 + (brp, refScript) <- runDeployScript 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 + undefined \ No newline at end of file diff --git a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs index b4ef5e93..69aa33bf 100644 --- a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs +++ b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs @@ -38,6 +38,7 @@ data BetRefParams = BetRefParams , 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. } + deriving stock (Show) -- PlutusTx.makeLift ''BetRefParams PlutusTx.unstableMakeIsData ''BetRefParams diff --git a/tests-unified/atlas-unified-tests.hs b/tests-unified/atlas-unified-tests.hs index 21f2ef09..c5e5aae7 100644 --- a/tests-unified/atlas-unified-tests.hs +++ b/tests-unified/atlas-unified-tests.hs @@ -9,6 +9,15 @@ 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] +main = do + defaultMain $ testGroup "Emulator" + [ placeBetTestsClb + , takeBetPotTestsClb + ] + withPrivnet cardanoDefaultTestnetOptions $ \setup -> + defaultMain $ testGroup "Privnet" + [ placeBetTests setup + , takeBetPotTests setup + ] \ No newline at end of file