diff --git a/.gitignore b/.gitignore index a3ddf0fe..0bd965e1 100644 --- a/.gitignore +++ b/.gitignore @@ -25,6 +25,7 @@ cabal.project.local~ .DS_Store maestro-config.json blockfrost-config.json +log.txt *.skey .direnv secrets/ diff --git a/atlas-cardano.cabal b/atlas-cardano.cabal index d204ad37..817646a7 100644 --- a/atlas-cardano.cabal +++ b/atlas-cardano.cabal @@ -400,8 +400,11 @@ test-suite atlas-unified-tests build-depends: atlas-cardano, base, + bytestring, + cardano-api, containers, extra, + lens, mtl, plutus-core, plutus-ledger-api, diff --git a/cabal.project b/cabal.project index c97c6ab9..a5c99c79 100644 --- a/cabal.project +++ b/cabal.project @@ -46,9 +46,11 @@ source-repository-package -- TODO: Temporary, until proposed changes are in upstream (track https://github.com/mlabs-haskell/clb/pull/44) source-repository-package type: git - location: https://github.com/sourabhxyz/clb - tag: 09414a93047b4c7f6e03e20d1730c9c0f88e1d46 - --sha256: sha256-y5fF8IDywt/pQ3HsRE6CpAlqK4uiU/SRuDIqSHxBED0= + location: https://github.com/mlabs-haskell/clb + tag: 080e2b4852f162d33e8a3d5e2faaa9b5400d878c + --sha256: sha256-IazNffJyUIPZh3ypiSBpfdZAenWD5oixfzrhYJlrI8s= + subdir: + clb -- Obtaining cardano-node stuff for 9.1.0. These aren't published on CHaP yet. source-repository-package diff --git a/flake.nix b/flake.nix index faddf1ce..cebab4c9 100644 --- a/flake.nix +++ b/flake.nix @@ -37,6 +37,7 @@ cabal = {} ; hlint = {}; haskell-language-server = {}; + fourmolu = {}; }; # Non-Haskell shell tools go here shell.buildInputs = with pkgs; [ diff --git a/src/GeniusYield/Test/Clb.hs b/src/GeniusYield/Test/Clb.hs index 9aad3cec..ed0490f2 100644 --- a/src/GeniusYield/Test/Clb.hs +++ b/src/GeniusYield/Test/Clb.hs @@ -59,20 +59,20 @@ import Cardano.Slotting.Time ( ) import Clb ( Clb, + ClbConfig (..), ClbState (..), ClbT, EmulatedLedgerState (..), Log (Log), LogEntry (LogEntry), LogLevel (..), - MockConfig (..), SlotConfig (..), ValidationResult (..), getCurrentSlot, getFails, logError, logInfo, - sendTx, + submitTx, txOutRefAt, txOutRefAtPaymentCred, unLog, @@ -162,7 +162,7 @@ liftClb = GYTxMonadClb . lift . lift . lift . lift -} mkTestFor :: String -> (TestInfo -> GYTxMonadClb a) -> Tasty.TestTree mkTestFor name action = - testNoErrorsTraceClb v w Clb.defaultConway name $ do + testNoErrorsTraceClb v w Clb.defaultConwayClbConfig name $ do asClb pureGen (w1 testWallets) nextWalletInt $ action TestInfo {testGoldAsset = fakeCoin fakeGold, testIronAsset = fakeCoin fakeIron, testWallets} where @@ -196,17 +196,17 @@ mkTestFor name action = nextWalletInt = 10 -- \| Helper for building tests - testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.MockConfig ApiEra -> String -> AtlasClb a -> Tasty.TestTree + testNoErrorsTraceClb :: GYValue -> GYValue -> Clb.ClbConfig ApiEra -> String -> AtlasClb 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) + (mbErrors, mock) = Clb.runClb (act >> Clb.checkErrors) $ Clb.initClb cfg (valueToApi funds) (valueToApi walletFunds) Nothing mockLog = "\nEmulator log :\n--------------\n" <> logString options = defaultLayoutOptions {layoutPageWidth = AvailablePerLine 150 1.0} - logDoc = Clb.ppLog $ Clb.mockInfo mock + logDoc = Clb.ppLog $ Clb._clbLog mock logString = renderString $ layoutPretty options logDoc mkSimpleWallet :: TL.KeyPair r L.StandardCrypto -> User @@ -238,12 +238,12 @@ mustFailWith isExpectedError act = do tryError (void act) >>= \case Left e@(isExpectedError -> True) -> do gyLogInfo' "" . printf "Successfully caught expected exception %s" $ show e - infoLog <- liftClb $ gets mockInfo + infoLog <- liftClb $ gets (^. Clb.clbLog) postFails <- liftClb getFails liftClb $ put st - { mockInfo = infoLog <> mkMustFailLog preFails postFails + { _clbLog = infoLog <> mkMustFailLog preFails postFails -- , mustFailLog = mkMustFailLog preFails postFails } Left err -> liftClb $ logError $ "Action failed with unexpected exception: " ++ show err @@ -260,7 +260,7 @@ instance MonadError GYTxMonadException GYTxMonadClb where instance GYTxQueryMonad GYTxMonadClb where networkId = do - magic <- liftClb $ gets (mockConfigNetworkId . mockConfig) + magic <- liftClb $ gets (clbConfigNetworkId . Clb._clbConfig) -- TODO: Add epoch slots and network era to clb and retrieve from there. pure . GYPrivnet $ GYNetworkInfo @@ -270,7 +270,7 @@ instance GYTxQueryMonad GYTxMonadClb where lookupDatum :: GYDatumHash -> GYTxMonadClb (Maybe GYDatum) lookupDatum h = liftClb $ do - mdh <- gets mockDatums + mdh <- gets (^. Clb.knownDatums) return $ do d <- Map.lookup (datumHashToPlutus h) mdh return $ datumFromPlutus d @@ -309,7 +309,7 @@ instance GYTxQueryMonad GYTxMonadClb where utxoAtTxOutRef ref = do -- All UTxOs map - utxos <- liftClb $ gets (L.unUTxO . L.S.utxosUtxo . L.S.lsUTxOState . _memPoolState . emulatedLedgerState) + utxos <- liftClb $ gets (L.unUTxO . L.S.utxosUtxo . L.S.lsUTxOState . Clb._ledgerState . Clb._chainState) -- Maps keys to Plutus TxOutRef let m = Map.mapKeys (txOutRefToPlutus . txOutRefFromApi . Api.S.fromShelleyTxIn) utxos @@ -412,7 +412,7 @@ instance GYTxMonad GYTxMonadClb where let txBody = getTxBody tx dumpBody txBody gyLogDebug' "" $ "encoded tx: " <> txToHex tx - vRes <- liftClb . sendTx $ txToApi tx + vRes <- liftClb . Clb.submitTx $ txToApi tx case vRes of Success _state _onChainTx -> pure $ txBodyTxId txBody Fail _ err -> throwAppError . someBackendError . T.pack $ show err @@ -469,14 +469,14 @@ instance GYTxGameMonad GYTxMonadClb where slotConfig' :: GYTxMonadClb (UTCTime, NominalDiffTime) slotConfig' = liftClb $ do - sc <- gets $ mockConfigSlotConfig . mockConfig + sc <- gets $ Clb.clbConfigSlotConfig . _clbConfig let len = fromInteger (scSlotLength sc) / 1000 zero = posixSecondsToUTCTime $ timeToPOSIX $ timeFromPlutus $ scSlotZeroTime sc return (zero, len) protocolParameters :: GYTxMonadClb (ConwayCore.PParams (Api.S.ShelleyLedgerEra ApiEra)) protocolParameters = do - pparams <- liftClb $ gets $ mockConfigProtocol . mockConfig + pparams <- liftClb $ gets $ clbConfigProtocol . _clbConfig pure $ coerce pparams instance GYTxSpecialQueryMonad GYTxMonadClb where diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs index 7b918387..245b5775 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/Operations.hs @@ -1,60 +1,42 @@ module GeniusYield.Test.Unified.BetRef.Operations ( mkScript, - mkBetRefValidator, - betRefAddress, placeBet, takeBets, ) where +import Cardano.Api qualified as Api import GeniusYield.Imports import GeniusYield.TxBuilder import GeniusYield.Types import GeniusYield.Test.Unified.OnChain.BetRef.Compiled +import System.IO.Unsafe (unsafePerformIO) -{- | Queries the cuurent slot, calculates parameters and builds -a script that is ready to be deployed. --} -mkScript :: - GYTxQueryMonad m => - -- | How many slots betting should be open - Integer -> - -- | How many slots should pass before oracle reveals answer - Integer -> - -- | Oracle PKH - GYPubKeyHash -> - -- | Bet step value - GYValue -> - 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) +-- import PlutusCore.Data qualified as PLC +import PlutusCore.MkPlc qualified as PLC --- | Validator in question, obtained after giving required parameters. -mkBetRefValidator :: BetRefParams -> GYScript PlutusV2 -mkBetRefValidator brp = validatorFromPlutus $ betRefValidator brp +import UntypedPlutusCore (DeBruijn, DefaultFun, DefaultUni, Program) +import UntypedPlutusCore qualified as UPLC + +import Cardano.Api.Shelley qualified as Api +import Control.Lens (over) +import PlutusLedgerApi.V1 +import System.Environment (lookupEnv) --- | Address of the validator, given params. -betRefAddress :: (HasCallStack, GYTxQueryMonad m) => BetRefParams -> m GYAddress -betRefAddress brp = scriptAddress $ mkBetRefValidator brp +-------------------------------------------------------------------------------- +-- Operations +-------------------------------------------------------------------------------- -- | Operation to place bet. placeBet :: - (HasCallStack, GYTxQueryMonad m) => - -- | Reference Script. + ( HasCallStack + , GYTxQueryMonad m + , v `VersionIsGreaterOrEqual` 'PlutusV2 + ) => + -- | Reference Script output. GYTxOutRef -> + -- | Script + GYValidator v -> -- | Validator Params. BetRefParams -> -- | Guess. @@ -65,13 +47,13 @@ placeBet :: GYAddress -> -- | Reference to previous bets UTxO (if any). Maybe GYTxOutRef -> - m (GYTxSkeleton 'PlutusV2) -placeBet refScript brp guess bet ownAddr mPreviousBetsUtxoRef = do + m (GYTxSkeleton v) +placeBet refScript script brp guess bet ownAddr mPreviousBetsUtxoRef = do gyLogDebug' "" $ printf "ownAddr: %s" (show ownAddr) gyLogDebug' "" $ printf "refOut: %s" (show mPreviousBetsUtxoRef) pkh <- addressToPubKeyHash' ownAddr - betAddr <- betRefAddress brp + betAddr <- scriptAddress $ coerce script case mPreviousBetsUtxoRef of -- This is the first bet. Nothing -> do @@ -92,7 +74,7 @@ placeBet refScript brp guess bet ownAddr mPreviousBetsUtxoRef = do betUntilSlot <- enclosingSlotFromTime' (timeFromPlutus $ brpBetUntil brp) gyLogDebug' "" $ printf "3. bet until slot %s" (show betUntilSlot) return $ - input brp refScript previousBetsUtxoRef dat (Bet guess) + input refScript (validatorToScript script) previousBetsUtxoRef dat (Bet guess) <> mustHaveOutput GYTxOut { gyTxOutAddress = betAddr @@ -109,9 +91,15 @@ placeBet refScript brp guess bet ownAddr mPreviousBetsUtxoRef = do -- | Operation to take UTxO corresponding to previous bets. takeBets :: - (HasCallStack, GYTxQueryMonad m) => - -- | Reference Script. + forall m v. + ( HasCallStack + , GYTxQueryMonad m + , v `VersionIsGreaterOrEqual` 'PlutusV2 + ) => + -- | Reference Script output. GYTxOutRef -> + -- | The script + GYValidator v -> -- | Validator params. BetRefParams -> -- | Script UTxO to consume. @@ -120,27 +108,120 @@ takeBets :: GYAddress -> -- | Oracle reference input. GYTxOutRef -> - m (GYTxSkeleton 'PlutusV2) -takeBets refScript brp previousBetsUtxoRef ownAddr oracleRefInput = do + m (GYTxSkeleton v) +takeBets refScript script 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 + input refScript (validatorToScript script) 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 = +-- | Utility builder +input :: + v `VersionIsGreaterOrEqual` 'PlutusV2 => + GYTxOutRef -> + GYScript v -> + GYTxOutRef -> + BetRefDatum -> + BetRefAction -> + GYTxSkeleton v +input refScript script inputRef dat red = mustHaveInput GYTxIn { gyTxInTxOutRef = inputRef , gyTxInWitness = GYTxInWitnessScript - (GYInReference refScript $ validatorToScript $ mkBetRefValidator brp) + (GYInReference refScript script) (datumFromPlutusData dat) (redeemerFromPlutusData red) } + +-------------------------------------------------------------------------------- +-- Additional operations +-------------------------------------------------------------------------------- + +{- | Queries the cuurent slot, calculates parameters and builds +a script that is ready to be deployed. +-} +mkScript :: + forall m (v :: PlutusVersion). + ( GYTxQueryMonad m + , SingPlutusVersionI v + , Api.IsPlutusScriptLanguage (PlutusVersionToApi v) + ) => + -- | How many slots betting should be open + Integer -> + -- | How many slots should pass before oracle reveals answer + Integer -> + -- | Oracle PKH + GYPubKeyHash -> + -- | Bet step value + GYValue -> + m (BetRefParams, GYValidator v) +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) + -- TODO: this might be improved once support for blueprints is merged. + let s = unsafePerformIO $ do + lookupEnv "AIKEN_BET_REF" >>= \case + Nothing -> pure $ mkBetRefValidator params + Just _ -> do + putStrLn "Using Aiken-based on-chain script" + mkBetRefValidatorExt params + pure (params, s) + +{- | Validator in question, obtained after giving required parameters. +This uses PlutusTx version of the validator +-} +mkBetRefValidator :: + forall (v :: PlutusVersion). + SingPlutusVersionI v => + BetRefParams -> + GYValidator v +mkBetRefValidator brp = validatorFromPlutus $ betRefValidator brp + +-- | Make a validator out of external UPLC envelope +mkBetRefValidatorExt :: + forall (v :: PlutusVersion). + SingPlutusVersionI v => + BetRefParams -> + IO (GYValidator v) +mkBetRefValidatorExt BetRefParams {..} = do + v <- readValidator @v "tests-unified/script/bet_ref_validator.plutus" + let (Api.PlutusScriptSerialised sbs) = validatorToApi v + let prog :: UPLCProgram = uncheckedDeserialiseUPLC sbs + let params = + Constr + 0 + [ toData brpOraclePkh + , toData brpBetUntil + , toData brpBetReveal + , toData brpBetStep -- TODO: might be flaky + ] + let args = [params] + let appliedProg = applyArguments prog args + -- print $ Api.pretty appliedProg + pure $ validatorFromSerialisedScript @v $ serialiseUPLC appliedProg + +type UPLCProgram = Program DeBruijn DefaultUni DefaultFun () + +applyArguments :: UPLCProgram -> [Data] -> UPLCProgram +applyArguments p args = + let termArgs = fmap ((,) () . PLC.mkConstant ()) args + apply t = PLC.mkIterApp t termArgs + in over UPLC.progTerm apply p diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs index ca4ed04f..10b8b216 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/PlaceBet.hs @@ -41,7 +41,7 @@ placeBetTestsClb = "Place bet" [ mkTestFor "Simple tx" simpleTxTest , mkTestFor "Placing first bet" firstBetTest' - , mkTestFor "Multiple bets" multipleBetsTest + , mkTestFor "Multiple bets - good steps" multipleBetsTest , mkTestFor "Multiple bets - to small step" $ mustFail . failingMultipleBetsTest ] @@ -52,7 +52,7 @@ placeBetTests setup = "Place bet" [ mkPrivnetTestFor_ "Simple tx" simpleTxTest , mkPrivnetTestFor_ "Placing first bet" firstBetTest' - , mkPrivnetTestFor_ "Multiple bets" multipleBetsTest + , mkPrivnetTestFor_ "Multiple bets - good steps" multipleBetsTest , mkPrivnetTestFor' "Multiple bets - too small step" GYDebug setup $ handleError ( \case @@ -109,9 +109,13 @@ mkTrivialTx = do -- | Run to call the `placeBet` operation. runPlaceBet :: - GYTxGameMonad m => + ( GYTxGameMonad m + , v `VersionIsGreaterOrEqual` 'PlutusV2 + ) => -- | Script output reference GYTxOutRef -> + -- | Script + GYValidator v -> -- | Parameters BetRefParams -> -- | Bet guess @@ -123,7 +127,7 @@ runPlaceBet :: -- | User that plays bet User -> m GYTxId -runPlaceBet refScript brp guess bet mPrevBets user = do +runPlaceBet refScript script brp guess bet mPrevBets user = do gyLogDebug' "" $ printf "placing a bet with guess %s and value %s" @@ -136,7 +140,7 @@ runPlaceBet refScript brp guess bet mPrevBets user = do pure $ listToMaybe <$> ownAddresses -- Call the operation - skeleton <- placeBet refScript brp guess bet addr mPrevBets + skeleton <- placeBet refScript script brp guess bet addr mPrevBets buildTxBody skeleton >>= signAndSubmitConfirmed firstBetTest' :: GYTxGameMonad m => TestInfo -> m () @@ -159,9 +163,9 @@ firstBetTest :: TestInfo -> m () firstBetTest betUntil betReveal betStep dat bet (testWallets -> ws@Wallets {w1}) = do - (brp, refScript) <- runDeployScript betUntil betReveal betStep ws + (brp, refScript, script) <- runDeployScript betUntil betReveal betStep ws withWalletBalancesCheckSimple [w1 := valueNegate bet] $ do - void $ runPlaceBet refScript brp dat bet Nothing w1 + void $ runPlaceBet refScript script brp dat bet Nothing w1 -- ----------------------------------------------------------------------------- -- Multiple bets @@ -227,12 +231,12 @@ mkMultipleBetsTest :: m () mkMultipleBetsTest betUntil betReveal betStep bets ws = do -- Deploy script - (brp, refScript) <- runDeployScript betUntil betReveal betStep ws + (brp, refScript, script) <- runDeployScript betUntil betReveal betStep ws -- Get the balance balanceBefore <- getBalance gyLogDebug' "" $ printf "balanceBeforeAllTheseOps: %s" (mconcat balanceBefore) -- Run operations - runMultipleBets brp refScript bets ws + runMultipleBets brp refScript script bets ws -- Get the balance again balanceAfter <- getBalance gyLogDebug' "" $ printf "balanceAfterAllTheseOps: %s" (mconcat balanceAfter) @@ -303,29 +307,33 @@ mkMultipleBetsTest betUntil betReveal betStep bets ws = do -- | Runner for multiple bets. runMultipleBets :: - GYTxGameMonad m => + ( GYTxGameMonad m + , v `VersionIsGreaterOrEqual` 'PlutusV2 + ) => BetRefParams -> -- | Reference script GYTxOutRef -> + -- | Script + GYValidator v -> [Bet] -> Wallets -> m () -runMultipleBets brp refScript bets ws = go bets True +runMultipleBets brp refScript script 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) + void $ runPlaceBet refScript script 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 + betRefAddr <- scriptAddress script GYUTxO {utxoRef} <- head . utxosToList <$> utxosAtAddress betRefAddr Nothing gyLogDebug' "" $ printf "previous bet utxo: %s" utxoRef - void $ runPlaceBet refScript brp dat bet (Just utxoRef) (getWallet ws) + void $ runPlaceBet refScript script brp dat bet (Just utxoRef) (getWallet ws) go remBets False -- ----------------------------------------------------------------------------- @@ -342,12 +350,12 @@ runDeployScript :: -- | Bet step value GYValue -> Wallets -> - m (BetRefParams, GYTxOutRef) + m (BetRefParams, GYTxOutRef, GYValidator PlutusV2) 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 + refScript <- addRefScript sAddr (validatorToScript script) gyLogDebug' "" $ printf "Ref script deployed, ref output is: %s" (show refScript) - pure (params, refScript) + pure (params, refScript, script) diff --git a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs index 8a4d0e08..bff160ec 100644 --- a/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs +++ b/tests-unified/GeniusYield/Test/Unified/BetRef/TakePot.hs @@ -11,7 +11,7 @@ import Test.Tasty ( testGroup, ) -import GeniusYield.HTTP.Errors (someBackendError) +import GeniusYield.HTTP.Errors import GeniusYield.Imports import GeniusYield.Test.Clb import GeniusYield.Test.Privnet.Setup @@ -26,7 +26,7 @@ takeBetPotTestsClb :: TestTree takeBetPotTestsClb = testGroup "Take bet pot" - [ mkTestFor "Take bet pot" takeBetsTest + [ mkTestFor "Just take bet pot" takeBetsTest , mkTestFor "Take by wrong guesser" $ mustFail . wrongGuesserTakeBetsTest , mkTestFor "The first bet matters" $ @@ -38,7 +38,7 @@ takeBetPotTests :: Setup -> TestTree takeBetPotTests setup = testGroup "Take bet pot" - [ mkPrivnetTestFor_ "Take bet pot" takeBetsTest + [ mkPrivnetTestFor_ "Just take bet pot" takeBetsTest , mkPrivnetTestFor_ "Take by wrong guesser" $ mustFailPrivnet . wrongGuesserTakeBetsTest , mkPrivnetTestFor_ "The first bet matters" $ @@ -130,12 +130,12 @@ mkTakeBetsTest :: Wallets -> m () mkTakeBetsTest betUntil betReveal betStep walletBets answer getTaker ws@Wallets {..} = do - (brp, refScript) <- runDeployScript betUntil betReveal betStep ws - runMultipleBets brp refScript walletBets ws + (brp, refScript, script) <- runDeployScript betUntil betReveal betStep ws + runMultipleBets brp refScript script walletBets ws -- Now lets take the bet refInput <- asUser w1 $ addRefInput True (userAddr w8) (datumFromPlutusData $ OracleAnswerDatum answer) let taker = getTaker ws - betRefAddr <- betRefAddress brp + betRefAddr <- scriptAddress script GYUTxO {utxoRef, utxoValue} <- head . utxosToList <$> utxosAtAddress betRefAddr Nothing @@ -144,17 +144,27 @@ mkTakeBetsTest betUntil betReveal betStep walletBets answer getTaker ws@Wallets gyLogDebug' "" $ "waiting till slot: " <> show waitUntil waitUntilSlot_ waitUntil withWalletBalancesCheckSimple [taker := utxoValue] - . asUser taker . void - $ takeBetsRun refScript brp utxoRef refInput + $ takeBetsRun refScript script brp utxoRef refInput taker -- | 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 +takeBetsRun :: + ( GYTxGameMonad m + , v `VersionIsGreaterOrEqual` 'PlutusV2 + ) => + GYTxOutRef -> + GYValidator v -> + BetRefParams -> + GYTxOutRef -> + GYTxOutRef -> + User -> + m GYTxId +takeBetsRun refScript script brp toConsume refInput taker = do + asUser taker $ do + addr <- + maybeM + (throwAppError $ someBackendError "No own addresses") + pure + $ listToMaybe <$> ownAddresses + skeleton <- takeBets refScript script brp toConsume addr refInput + buildTxBody skeleton >>= signAndSubmitConfirmed diff --git a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs index 00d1f829..39254dbb 100644 --- a/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs +++ b/tests-unified/GeniusYield/Test/Unified/OnChain/BetRef.hs @@ -50,7 +50,6 @@ data BetRefParams = BetRefParams } deriving stock Show --- 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). diff --git a/tests-unified/atlas-unified-tests.hs b/tests-unified/atlas-unified-tests.hs index c0ab37f2..42ebb145 100644 --- a/tests-unified/atlas-unified-tests.hs +++ b/tests-unified/atlas-unified-tests.hs @@ -20,10 +20,11 @@ main = do [ placeBetTestsClb , takeBetPotTestsClb ] - withPrivnet cardanoDefaultTestnetOptionsConway $ \setup -> - defaultMain $ - testGroup - "Privnet" - [ placeBetTests setup - , takeBetPotTests setup - ] + +-- withPrivnet cardanoDefaultTestnetOptionsConway $ \setup -> +-- defaultMain $ +-- testGroup +-- "Privnet" +-- [ placeBetTests setup +-- , takeBetPotTests setup +-- ] diff --git a/tests-unified/script/bet_ref_validator.plutus b/tests-unified/script/bet_ref_validator.plutus new file mode 100644 index 00000000..b3ee3dff --- /dev/null +++ b/tests-unified/script/bet_ref_validator.plutus @@ -0,0 +1,5 @@ +{ + "type": "PlutusScriptV2", + "description": "Generated by Aiken", + "cborHex": "590de6590de301000032323232323232223232323232232322533300c32323232323232323232325333017300e30183754002264646464a666036602e60386ea80044c8c8c8c8c8c8c8c8c94c8ccc094c084c098dd500e89999919191919111192999817181518179baa00113232325333034303700213232325333034303030353754002264a66606a6062606c6ea80044c8c8c8c94ccc0f0c0fc0084c8c8c8c8c94ccc0f8cc080c09ccc1093010ad8799fd87980d87a80ff0033042302733042301a33042375005e97ae03304233303e4a298103d87a80004c0103d87980004bd7025eb80c07cc100dd500909919299982198230010a99982019baf374e660886052660886ea4004cc1100592f5c00086e9c02854ccc100c8cc078c8ccc004004ccc06ccc068044c0088c0b0cc11cdd4000a5eb80cc068cc064cc064040c0bc0140b8c0088c07ccc11cdd4000a5eb80888c0b8cc124dd3191998008008018011112999825801080089919980200218278019991191980080080291299982800089982899bb0375200800697adef6c601323232325333051337200100042660aa66ec0dd48040038028a99982899b8f0080021325333052304e305337540022660ac66ec0dd4804982b982a1baa0010041004303a33055323232325333055305130563754004264a6660ac609a60ae6ea80104cdd2a4008660b46ea0004cc168c16cc160dd500225eb80008dd6982d182b9baa0020011325333055304c30563754004264a6660ac60a460ae6ea80104cdd2a4008660b460b660b06ea8010cc168dd4000a5eb80008dd6982d182b9baa0020011630580023057305800133055007330550014bd7025eb804cc154cdd81ba9002001330060060033052003375c60a000460a800460a40026eb8c128004c12c004c1340092f5c097ae022253330470021001132333004004304b0033232323300100100522533304c001100313304d304e00133002002304f0013020375660900046eb8c118004c1240088c94ccc10cc0fc0044cdc4a40006eb4c120c114dd50010a999821981d000899b89375a6090608a6ea80092000132337126eb4c124c128004dd6982480098229baa00230433754002444646600200200444a666090002297adef6c601323304a33760608e002600c6eb4c120004cc00c00cc130008c12800454ccc100cdd79ba600e374c6602e01e66030605a01044646600200200444a66608e002297adef6c601323304933760608c0026ea0cdc0a40006eb4c11c004cc00c00cc12c008c1240045288b0b0b0b1bae30440013758604460806ea804858dd5982118218011bac3041001303d37540726606e004464660726eacc0f80088c8dd698200011bae303e001375c60780026606c006460680022c6eacc0f4004c0f4008dd6181d800981b9baa001163039303637540022c6464a66606a60300022603c660726074606e6ea80092f5c02a66606a60580022664464a666070605e60726ea80044c94ccc0f0004530103d87a8000130223303d303e0014bd701919800800a5eb80894ccc0f400452f5c026464a6660786066607a6ea80044cc0100100084cc100c104c0f8dd50009980200200119299981e180f981e9baa001132533303d3371e6e50dd98008038981319820800a5eb805300103d87a80003041303e37540022980103d87a8000301b303d3754608000460800022002646600200200644a6660780022980103d87a8000132323232533303d3372200e0042a66607a66e3c01c0084c098cc1040052f5c0298103d87a8000133006006003303e003375c60780046080004607c0026eacc0e8c0ecc0ecc0ecc0ecc0ecc0ecc0ecc0ecc0ecc0ecc0dcdd50049bae303a303737540042980103d87a8000303537540026026606a6ea800cdd5980e981a1baa301d303437540086eacc070c0ccdd50008b181a80099806980b18189baa301a30313754002006606660606ea800458cc054dd6180a18179baa00123375e602a60606ea800400c88ccc010008004888c94ccc0bd4ccc0c80045288a5014c0103d87a80001301833033374c00297ae0323330010010030022225333034002100113233300400430380033322323300100100522533303900113303a337606ea4010dd4001a5eb7bdb1804c8c8c8c94ccc0e8cdc800400109981f19bb037520106ea001c01454ccc0e8cdc7804001099299981d981b981e1baa00113303f337606ea4024c100c0f4dd5000802080219299981d981b8008a60103d87a8000130243303f375000297ae03370000e00226607c66ec0dd48011ba800133006006003375a60760066eb8c0e4008c0f4008c0ec004dd718198009bad3034001303600222323300100100322533302f00114bd6f7b630099191981919bb037520026e98cc014004dd5981800119802002181a0019bae302e001303100122232333001001004003222533303000210011323330040043034003333301c002375c605e0026eacc0c0004014c0c8008c004004894ccc0a800452f5c02660566052605800266004004605a0026054604e6ea8074c030c09cdd5005180618139baa01a133223232533302c302f00213232533302b3027302c37540022646464a6660626068004264a66605e602460606ea80044c8c8c8c8c8c94ccc0d4c0c4c0d8dd50008a99981a99b8f375c6074606e6ea80040a054ccc0d4cc05cc078cc0e4c078cc0e4c044cc0e4dd401225eb80cc0e4ccc0d528a60103d87a80004c0103d87980004bd701981ca6010ad8799fd87b80d87a80ff004bd70180b181b9baa00f13253330363032303737540022a66607266028603a60706ea8c084c0e0dd5181d981c1baa001010153330363301300d233712008600a6078607a60726ea80045288b0b0b1980e9bac301c3037375401e466ebcc074c0e0dd50008088b0b0b181c981b1baa301b30363754603e606c6ea801cc0040208c94ccc0d0cdc4000a4000266e0520000011001337020046eb4c0e0c0d4dd50009bad3036303337540046056002606860626ea800458c038c0c0dd5180c98181baa0011630320013300b3758602e605c6ea80188cdd7981918199819981998179baa3018302f3754002980103d87a800030303031302d37546060605a6ea800458cc0480048cdc79bae3030302d37540020066eb0c0b8c0acdd50138b1bae302d0013758601660526ea8004c030c09cdd5005180618139baa01a374a90011119198008008019129998150008a5113253330283004302d00213300300300114a0605a00244660066eb0c010c098dd5000919baf300c3027375400200644646600200200644a666050002297ae0132325333027300500213302b00233004004001133004004001302c002302a001230263027302700123025302630263026302630263026302600122323232323232325333027323253330293025302a375400229444c8c94ccc0acc088c0b0dd50018992999816181198169baa003132533302d00a133712004002266e20008004dd6981898171baa003002375a6060605a6ea800c00454ccc0a8c034c0acdd50010a5014a0605c605e004605a00266056605800a66056605860526ea8c0b00192f5c020022940c8c94ccc0a0c090c0a4dd50008a5013232533302a3021302b3754006264a666056604460586ea800c4c94ccc0b001c4cdc4800801099b88001002375a6060605a6ea800c008dd6981798161baa00300115333029300c302a3754004294452818169817001181600099815181580119815181598141baa302b302c0054bd7019b8848000c098dd51815181580098131baa3029302a00433710900018121baa3028302900130243754604e00460466ea8008c088dd50011b87480108c088c08cc08cc08cc08cc08cc08cc08cc08c004c080c074dd50008b199119802001119baf3004301f37540020046eb0c004c070dd51800980e1baa00f301f301c37540084603e00244646600200200644a66603e0022980103d87a800013232533301e300500213007330220024bd70099802002000981180118108009ba54800058c004c060dd50059180d980e00098009bab3019301a0042323300100100222533301900114bd6f7b6300999119191999804001801000911319190011919198008008019129998100008a4c264a6660420022a66603c60086eb4c080c08c008526161323232325333022337206eb8c08c010dd718118018a9998111804000899803803998130018010b0b1bad30230033026003302400230230023023001233301b30170014a0944dd5980d8019bae3019002301b00133002002301c0012222323300100100522533301b00113301c337606ea4014dd300225eb7bdb1804c8c8c8c94ccc070cdc800480109981019bb037520126e9802001454ccc070cdc7804801099299980e980c980f1baa001133021337606ea4028c088c07cdd5000802080219980380480400089981019bb037520046e98004cc01801800cdd5980e8019bae301b002301f002301d001375a602c002602c0046eb4c050004c050008dd7180900098071baa00b14984d958c94ccc02cc01c0044c8c94ccc040c04c0084c9263008001163011001300d37540062a66601660040022a66601c601a6ea800c5261616300b37540046e1d2002533300730033008375400a264646464a66601c6022004264649319804801119198059bab3010002232375a60240046eb8c040004dd7180700099804001918030008b1bab300f001300f0023758601a00260126ea80145894ccc01cc00cc020dd50008991919192999807180880109924c600c0022c601e002601e0046eb8c034004c024dd50008b12999803180118039baa00113232533300b300e002149858dd6980600098041baa00116370e90001119198008008019129998050008a4c26466006006601c00460066018002ae6955ceaab9e5573eae815d0aba21" +} diff --git a/tests/GeniusYield/Test/GYTxBody.hs b/tests/GeniusYield/Test/GYTxBody.hs index 61e049d2..d3267c11 100644 --- a/tests/GeniusYield/Test/GYTxBody.hs +++ b/tests/GeniusYield/Test/GYTxBody.hs @@ -14,7 +14,7 @@ import Test.Tasty.HUnit ( (@?=), ) -import Clb.MockConfig ( +import Clb.Config ( defaultConwayParams, defaultSlotConfig, )