From 15078db86b180b07e54e84c44491168cc23d63bb Mon Sep 17 00:00:00 2001 From: euonymos Date: Sun, 25 Aug 2024 14:55:35 -0600 Subject: [PATCH 1/4] chore: clean up unified tests --- atlas-cardano.cabal | 1 + src/GeniusYield/Test/Privnet/Setup.hs | 2 +- src/GeniusYield/Test/Utils.hs | 5 +- .../Test/Unified/BetRef/Operations.hs | 38 +- .../Test/Unified/BetRef/PlaceBet.hs | 399 ++++++++++-------- .../Test/Unified/BetRef/TakePot.hs | 95 +++-- .../Test/Unified/OnChain/BetRef.hs | 1 + tests-unified/atlas-unified-tests.hs | 13 +- 8 files changed, 323 insertions(+), 231 deletions(-) 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 From 6f20a1fd65b1b02cf17b24c0760deb8456ee3f5b Mon Sep 17 00:00:00 2001 From: euonymos Date: Sun, 25 Aug 2024 15:12:01 -0600 Subject: [PATCH 2/4] chore: revert tests in take pot module --- .../Test/Unified/BetRef/TakePot.hs | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs index 1badd3a4..8be94a5c 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -93,13 +93,12 @@ takeBetsTrace betUntil' betReveal' betStep walletBets answer getTaker ws@Wallets let betUntil = currSlot + betUntil' betReveal = currSlot + betReveal' (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 + runMultipleBets 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 \ No newline at end of file From 16586bb7a743a24e933364866e91219d145424e2 Mon Sep 17 00:00:00 2001 From: euonymos Date: Mon, 26 Aug 2024 11:15:34 -0600 Subject: [PATCH 3/4] fix: fix take pot tests --- .../Test/Unified/BetRef/PlaceBet.hs | 1 + .../Test/Unified/BetRef/TakePot.hs | 90 +++++++++++-------- 2 files changed, 55 insertions(+), 36 deletions(-) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index 6dbea9b9..57c5b375 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -3,6 +3,7 @@ module GeniusYield.Test.Unified.BetRef.PlaceBet , placeBetTestsClb , runDeployScript , runMultipleBets + , Bet ) where import Control.Monad.Except (handleError) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs index 8be94a5c..4c09ebad 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -4,32 +4,39 @@ module GeniusYield.Test.Unified.BetRef.TakePot ) where import Control.Monad.Except (handleError) +import Control.Monad.Extra (maybeM) +import Data.Maybe (listToMaybe) + 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 +import GeniusYield.HTTP.Errors (someBackendError) 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 + [ mkTestFor "Take bet pot" takeBetsTest + , mkTestFor "Take by wrong guesser" $ + mustFail . wrongGuesserTakeBetsTest + , mkTestFor "The first bet matters" $ + mustFail . badUpdatedGuessTakeBetsTest ] -- | Our unit tests for taking the bet pot operation takeBetPotTests :: Setup -> TestTree takeBetPotTests setup = testGroup "Take bet pot" - [ mkPrivnetTestFor_ "Balance check after taking bet pot - privnet" takeBetsTest - , mkPrivnetTestFor_ "Must fail if attempt to take is by wrong guesser - privnet" $ mustFailPrivnet . wrongGuesserTakeBetsTest - , mkPrivnetTestFor_ "Must fail even if old guess was closest but updated one is not - privnet" $ mustFailPrivnet . badUpdatedGuessTakeBetsTest + [ mkPrivnetTestFor_ "Take bet pot" takeBetsTest + , mkPrivnetTestFor_ "Take by wrong guesser" $ + mustFailPrivnet . wrongGuesserTakeBetsTest + , mkPrivnetTestFor_ "The first bet matters" $ + mustFailPrivnet . badUpdatedGuessTakeBetsTest ] where mkPrivnetTestFor_ = flip mkPrivnetTestFor setup @@ -41,64 +48,75 @@ takeBetPotTests setup = testGroup "Take bet pot" ) takeBetsTest :: GYTxGameMonad m => TestInfo -> m () -takeBetsTest TestInfo{..} = takeBetsTrace 400 1_000 +takeBetsTest TestInfo{..} = mkTakeBetsTest + 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) + , (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) +wrongGuesserTakeBetsTest TestInfo{..} = mkTakeBetsTest + 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) + , (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) +badUpdatedGuessTakeBetsTest TestInfo{..} = mkTakeBetsTest + 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) + , (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 - 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' +mkTakeBetsTest + :: GYTxGameMonad m + => Integer + -> Integer + -> GYValue + -> [Bet] + -> Integer + -> (Wallets -> User) -- ^ Pot taker + -> Wallets + -> m () +mkTakeBetsTest betUntil betReveal betStep walletBets answer getTaker ws@Wallets{..} = do (brp, refScript) <- runDeployScript betUntil betReveal betStep ws runMultipleBets 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) + GYUTxO{utxoRef, utxoValue} <- head . utxosToList + <$> utxosAtAddress betRefAddr Nothing + currSlot <- slotToInteger <$> slotOfCurrentBlock + let waitUntil = slotFromApi (fromInteger $ currSlot + betReveal) + gyLogDebug' "" $ "waiting till slot: " <> show waitUntil + waitUntilSlot_ waitUntil withWalletBalancesCheckSimple [taker := utxoValue] . asUser taker - . void $ takeBetsRun refScript brp utxoRef refInput \ No newline at end of file + . void $ takeBetsRun refScript brp utxoRef refInput + +-- | Run to call the `takeBets` operation. +takeBetsRun :: GYTxMonad m => GYTxOutRef -> BetRefParams -> GYTxOutRef -> GYTxOutRef -> m GYTxId +takeBetsRun refScript brp toConsume refInput = do + addr <- maybeM (throwAppError $ someBackendError "No own addresses") + pure $ listToMaybe <$> ownAddresses + skeleton <- takeBets refScript brp toConsume addr refInput + buildTxBody skeleton >>= signAndSubmitConfirmed \ No newline at end of file From 58eb488878394f1b9603949f0a0c18ccafa0d35d Mon Sep 17 00:00:00 2001 From: euonymos Date: Wed, 4 Sep 2024 22:48:46 -0600 Subject: [PATCH 4/4] fix: update Nix setup --- .envrc | 7 +-- atlas-cardano.cabal | 4 +- cabal.project | 5 +- flake.lock | 124 +++++++++++++++++++++----------------------- flake.nix | 4 +- 5 files changed, 70 insertions(+), 74 deletions(-) diff --git a/.envrc b/.envrc index 7fd73aa3..8392d159 100644 --- a/.envrc +++ b/.envrc @@ -1,6 +1 @@ -# https://github.com/nix-community/nix-direnv A fast, persistent use_nix/use_flake implementation for direnv: -if ! has nix_direnv_version || ! nix_direnv_version 2.3.0; then - source_url "https://raw.githubusercontent.com/nix-community/nix-direnv/2.3.0/direnvrc" "sha256-Dmd+j63L84wuzgyjITIfSxSD57Tx7v51DMxVZOsiUD8=" -fi -# https://github.com/input-output-hk/devx Slightly opinionated shared GitHub Action for Cardano-Haskell projects -use flake "github:input-output-hk/devx?rev=086bfa55b40dfdaeb3c0381d876d50081b37c9a3#ghc96-iog-full" \ No newline at end of file +use flake \ No newline at end of file diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index c9a0a1de..30eb79ed 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -15,7 +15,9 @@ category: Blockchain, Cardano, Framework homepage: https://github.com/geniusyield/atlas#readme bug-reports: https://github.com/geniusyield/atlas/issues extra-source-files: README.md -tested-with: GHC ==9.6.5 +tested-with: + GHC ==9.6.5 + || ==9.6.6 source-repository head type: git diff --git a/cabal.project b/cabal.project index 9310ed74..2c425fcd 100644 --- a/cabal.project +++ b/cabal.project @@ -78,6 +78,9 @@ source-repository-package lib/wallet-benchmarks/ lib/wallet/ +package postgresql-libpq + flags: +use-pkg-config + ------ Following is mostly from @cardano-wallet@'s @cabal.project@ file. ------- -------------------------------------------------------------------------------- @@ -173,7 +176,7 @@ package cardano-node flags: -systemd package bitvec - flags: -simd + flags: -simd -- ------------------------------------------------------------------------- diff --git a/flake.lock b/flake.lock index c1ca74d4..f7f5bb4b 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1711548043, - "narHash": "sha256-mO+UfcsuqEo/xRkQwxJVAjCwoMAWqm1M0mQvG4YX0z0=", + "lastModified": 1725372492, + "narHash": "sha256-eQwfZIEHH5qHZQHXujgjj35dVAqSZa6EbTRWeppn1ME=", "owner": "input-output-hk", "repo": "cardano-haskell-packages", - "rev": "f6b61b647999413d3a4f11970f53d83c95890834", + "rev": "05c9f8fb28fde6e46d8768ce396a4482883d6bab", "type": "github" }, "original": { @@ -152,51 +152,14 @@ "type": "github" } }, - "ghc910X": { - "flake": false, - "locked": { - "lastModified": 1715269866, - "narHash": "sha256-gVCQO6nStym04KD7jz+Wl9xZBzpC7NzyC8/RWpf1utg=", - "ref": "ghc-9.10", - "rev": "2cc6968a0e70967a0fe906ff27957030eab40889", - "revCount": 62686, - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - }, - "original": { - "ref": "ghc-9.10", - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - } - }, - "ghc911": { - "flake": false, - "locked": { - "lastModified": 1716216952, - "narHash": "sha256-VwftfzfTI14u7r24cEzIOiwLwZj49+NOKB/hLD+Dg6Q=", - "ref": "refs/heads/master", - "rev": "d9e2c1197c401906af05fc1b7de55912ef183799", - "revCount": 66802, - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - }, - "original": { - "submodules": true, - "type": "git", - "url": "https://gitlab.haskell.org/ghc/ghc" - } - }, "hackage": { "flake": false, "locked": { - "lastModified": 1711498913, - "narHash": "sha256-plLtro20sMl5AX3z9vYyzybSngkNusB5pZavc1PxM3o=", + "lastModified": 1725409900, + "narHash": "sha256-XfSA7YyjHUfuNsCw4cE6p0kQcmrJgQq3nW36Cw/PAv0=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "e08be045443108c50a10fbc4abcf5d1d20a13625", + "rev": "d86e544dec33ce5fb0ad3981be91074d397b700d", "type": "github" }, "original": { @@ -214,8 +177,6 @@ "cardano-shell": "cardano-shell", "flake-compat": "flake-compat", "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", - "ghc910X": "ghc910X", - "ghc911": "ghc911", "hackage": "hackage", "hls-1.10": "hls-1.10", "hls-2.0": "hls-2.0", @@ -226,6 +187,7 @@ "hls-2.6": "hls-2.6", "hls-2.7": "hls-2.7", "hls-2.8": "hls-2.8", + "hls-2.9": "hls-2.9", "hpc-coveralls": "hpc-coveralls", "hydra": "hydra", "iserv-proxy": "iserv-proxy", @@ -240,16 +202,17 @@ "nixpkgs-2211": "nixpkgs-2211", "nixpkgs-2305": "nixpkgs-2305", "nixpkgs-2311": "nixpkgs-2311", + "nixpkgs-2405": "nixpkgs-2405", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", "stackage": "stackage" }, "locked": { - "lastModified": 1716166225, - "narHash": "sha256-gFMvOwooBevnHtZyGoiOcRes9ZSylG5YfNoqOHGdP/M=", + "lastModified": 1725411053, + "narHash": "sha256-cW999pULNLOZHlV9sqBFIrWTkSxuVAVR6xJR7GndHdQ=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "6aa8046087d4e6fd70f3b6b99628f77e398e9fd2", + "rev": "63783ecc949e99b2396ca821275cee26385adaba", "type": "github" }, "original": { @@ -411,6 +374,23 @@ "type": "github" } }, + "hls-2.9": { + "flake": false, + "locked": { + "lastModified": 1718469202, + "narHash": "sha256-THXSz+iwB1yQQsr/PY151+2GvtoJnTIB2pIQ4OzfjD4=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "40891bccb235ebacce020b598b083eab9dda80f1", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.9.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, "hpc-coveralls": { "flake": false, "locked": { @@ -453,11 +433,11 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1710581758, - "narHash": "sha256-UNUXGiKLGUv1TuQumV70rfjCJERP4w8KZEDxsMG0RHc=", + "lastModified": 1717479972, + "narHash": "sha256-7vE3RQycHI1YT9LHJ1/fUaeln2vIpYm6Mmn8FTpYeVo=", "owner": "stable-haskell", "repo": "iserv-proxy", - "rev": "50ea210590ab0519149bfd163d5ba199be925fb6", + "rev": "2ed34002247213fc435d0062350b91bab920626e", "type": "github" }, "original": { @@ -602,11 +582,11 @@ }, "nixpkgs-2305": { "locked": { - "lastModified": 1701362232, - "narHash": "sha256-GVdzxL0lhEadqs3hfRLuj+L1OJFGiL/L7gCcelgBlsw=", + "lastModified": 1705033721, + "narHash": "sha256-K5eJHmL1/kev6WuqyqqbS1cdNnSidIZ3jeqJ7GbrYnQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "d2332963662edffacfddfad59ff4f709dde80ffe", + "rev": "a1982c92d8980a0114372973cbdfe0a307f1bdea", "type": "github" }, "original": { @@ -618,11 +598,11 @@ }, "nixpkgs-2311": { "locked": { - "lastModified": 1701386440, - "narHash": "sha256-xI0uQ9E7JbmEy/v8kR9ZQan6389rHug+zOtZeZFiDJk=", + "lastModified": 1719957072, + "narHash": "sha256-gvFhEf5nszouwLAkT9nWsDzocUTqLWHuL++dvNjMp9I=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "293822e55ec1872f715a66d0eda9e592dc14419f", + "rev": "7144d6241f02d171d25fba3edeaf15e0f2592105", "type": "github" }, "original": { @@ -632,6 +612,22 @@ "type": "github" } }, + "nixpkgs-2405": { + "locked": { + "lastModified": 1720122915, + "narHash": "sha256-Nby8WWxj0elBu1xuRaUcRjPi/rU3xVbkAt2kj4QwX2U=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "835cf2d3f37989c5db6585a28de967a667a75fb1", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-24.05-darwin", + "repo": "nixpkgs", + "type": "github" + } + }, "nixpkgs-regression": { "locked": { "lastModified": 1643052045, @@ -650,17 +646,17 @@ }, "nixpkgs-unstable": { "locked": { - "lastModified": 1694822471, - "narHash": "sha256-6fSDCj++lZVMZlyqOe9SIOL8tYSBz1bI8acwovRwoX8=", + "lastModified": 1720181791, + "narHash": "sha256-i4vJL12/AdyuQuviMMd1Hk2tsGt02hDNhA0Zj1m16N8=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", + "rev": "4284c2b73c8bce4b46a6adf23e16d9e2ec8da4bb", "type": "github" }, "original": { "owner": "NixOS", + "ref": "nixpkgs-unstable", "repo": "nixpkgs", - "rev": "47585496bcb13fb72e4a90daeea2f434e2501998", "type": "github" } }, @@ -695,11 +691,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1711498142, - "narHash": "sha256-ZeNadDaI0LogObd1Jg/ZZTKALkN4ISANhJemcMTNSA4=", + "lastModified": 1725408838, + "narHash": "sha256-tHw95xcMElCqI6xOLmdTAEvQ0/4IS7WBZc+RF7HT/uk=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "00e65ae86901c3802465f5fd9ef13f1fcb3bf439", + "rev": "2ab3b5a823933ef199a289fbf39bbf0da0023100", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index a7f3cc58..faddf1ce 100644 --- a/flake.nix +++ b/flake.nix @@ -30,7 +30,7 @@ hixProject = final.haskell-nix.project' { src = ./.; - compiler-nix-name = "ghc964"; + compiler-nix-name = "ghc966"; # This is used by `nix develop .` to open a shell for use with # `cabal`, `hlint` and `haskell-language-server` shell.tools = { @@ -42,7 +42,7 @@ shell.buildInputs = with pkgs; [ nixpkgs-fmt ]; - inputMap = { "https://input-output-hk.github.io/cardano-haskell-packages" = CHaP; }; + inputMap = { "https://chap.intersectmbo.org/" = CHaP; }; }; }) overlay