diff --git a/MetaLamp/lending-pool/plutus-starter.cabal b/MetaLamp/lending-pool/plutus-starter.cabal index fed43d89a..f4b62f512 100644 --- a/MetaLamp/lending-pool/plutus-starter.cabal +++ b/MetaLamp/lending-pool/plutus-starter.cabal @@ -96,3 +96,46 @@ executable generate-purs plutus-use-cases, plutus-ledger, plutus-tx + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: + Spec.Start Spec.Deposit Spec.Withdraw Spec.ProvideCollateral Spec.RevokeCollateral Spec.Borrow Spec.Repay Spec.Shared Utils.Data Utils.Trace Fixtures Fixtures.Symbol Fixtures.Aave Fixtures.Asset Fixtures.Init Fixtures.Wallet + default-language: Haskell2010 + ghc-options: -Wall -Wnoncanonical-monad-instances + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities -rtsopts + -- See Plutus Tx readme + -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas + build-depends: + plutus-core -any, + plutus-tx -any, + plutus-contract -any, + plutus-ledger -any, + plutus-starter, + plutus-ledger-api, + plutus-tx-plugin + build-depends: + base >=4.9 && <5, + aeson -any, + bytestring -any, + containers -any, + data-default -any, + freer-extras -any, + hedgehog -any, + prettyprinter -any, + tasty -any, + tasty-hunit -any, + tasty-hedgehog >=0.2.0.0, + tasty-golden -any, + tasty-quickcheck -any, + text -any, + lens -any, + mtl -any, + row-types -any, + QuickCheck -any, + freer-simple -any, + foldl -any, + streaming -any diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/Endpoints.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/Endpoints.hs index eef45665c..18d584f0a 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/Endpoints.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/Endpoints.hs @@ -18,7 +18,8 @@ module Plutus.Contracts.Endpoints where -import Control.Monad (forM, forever, void) +import qualified Control.Lens as Lens +import Control.Monad hiding (fmap) import qualified Data.ByteString as BS import qualified Data.Map as Map import Data.Monoid (Last (..)) @@ -82,11 +83,16 @@ createReserve aave CreateParams {..} = -- | Starts the Lending Pool protocol: minting pool NFTs, creating empty user configuration state and all specified liquidity reserves start :: HasBlockchainActions s => [CreateParams] -> Contract w s Text Aave -start params = do +start = start' $ do pkh <- pubKeyHash <$> ownPubKey - aaveToken <- fmap Currency.currencySymbol $ + fmap Currency.currencySymbol $ mapError (pack . show @Currency.CurrencyError) $ Currency.forgeContract pkh [(Core.aaveProtocolName, 1)] + +start' :: HasBlockchainActions s => Contract w s Text CurrencySymbol -> [CreateParams] -> Contract w s Text Aave +start' getAaveToken params = do + aaveToken <- getAaveToken + pkh <- pubKeyHash <$> ownPubKey let aave = Core.aave aaveToken payment = assetClassValue (Core.aaveProtocolInst aave) 1 let aaveTokenTx = TxUtils.mustPayToScript (Core.aaveInstance aave) pkh (Core.LendingPoolDatum pkh) payment @@ -105,16 +111,38 @@ start params = do logInfo @Prelude.String $ printf "started Aave %s at address %s" (show aave) (show $ Core.aaveAddress aave) pure aave -ownerEndpoint :: [CreateParams] -> Contract (Last (Either Text Aave)) BlockchainActions Void () -ownerEndpoint params = do - e <- runError $ start params +data ContractResponse e a = ContractSuccess a | ContractError e | ContractPending + deriving stock (Prelude.Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +handleContract :: forall l a p r s. + HasEndpoint l p s + => Proxy l + -> (a -> r) + -> (p -> Contract (Last (ContractResponse Text r)) s Text a) + -> Contract (Last (ContractResponse Text r)) s Void () +handleContract _ g c = do + e <- runError $ do + p <- endpoint @l + _ <- tell $ Last $ Just ContractPending + errorHandler `handleError` c p tell $ Last $ Just $ case e of - Left err -> Left err - Right aa -> Right aa + Left err -> ContractError err + Right a -> ContractSuccess $ g a + where + errorHandler e = do + logInfo @Text ("Error submiting the transaction: " <> e) + throwError e type AaveOwnerSchema = BlockchainActions - .\/ Endpoint "start" () + .\/ Endpoint "start" [CreateParams] + +data OwnerContractState = Started Aave + deriving (Prelude.Eq, Show, Generic, FromJSON, ToJSON) + +ownerEndpoints :: Contract (Last (ContractResponse Text OwnerContractState)) AaveOwnerSchema Void () +ownerEndpoints = forever $ handleContract (Proxy @"start") Started start -- | Gets current Lending Pool reserves state reserves :: HasBlockchainActions s => Aave -> Contract w s Text (AssocMap.Map AssetClass Reserve) @@ -405,30 +433,6 @@ revokeCollateral aave RevokeCollateralParams {..} = do getUsersCollateral :: AssetClass -> TxOutTx -> Bool getUsersCollateral asset tx = ((> 0) . flip assetClassValueOf asset . txOutValue . txOutTxOut $ tx) && (txOutDatumHash . txOutTxOut $ tx) == Just (datumHash . Datum . PlutusTx.toData $ userDatum asset) - -data ContractResponse e a = ContractSuccess a | ContractError e | ContractPending - deriving stock (Prelude.Eq, Show, Generic) - deriving anyclass (ToJSON, FromJSON) - -handleContract :: forall l a p r s. - HasEndpoint l p s - => Proxy l - -> (a -> r) - -> (p -> Contract (Last (ContractResponse Text r)) s Text a) - -> Contract (Last (ContractResponse Text r)) s Void () -handleContract _ g c = do - e <- runError $ do - p <- endpoint @l - _ <- tell $ Last $ Just ContractPending - errorHandler `handleError` c p - tell $ Last $ Just $ case e of - Left err -> ContractError err - Right a -> ContractSuccess $ g a - where - errorHandler e = do - logInfo @Text ("Error submiting the transaction: " <> e) - throwError e - type AaveUserSchema = BlockchainActions .\/ Endpoint "deposit" DepositParams @@ -451,6 +455,8 @@ data UserContractState = | GetPubKeyBalance Value deriving (Prelude.Eq, Show, Generic, FromJSON, ToJSON) +Lens.makeClassyPrisms ''UserContractState + -- TODO ? add repayWithCollateral userEndpoints :: Aave -> Contract (Last (ContractResponse Text UserContractState)) AaveUserSchema Void () userEndpoints aave = forever $ diff --git a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs index 4fb30aadc..8bc8ab263 100644 --- a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs +++ b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs @@ -58,25 +58,28 @@ import Prelude hiding (init) import Wallet.Emulator.Types (Wallet (..), walletPubKey) import Wallet.Types (ContractInstanceId) -wallets :: [Wallet] -wallets = [Wallet i | i <- [1 .. 4]] +ownerWallet :: Wallet +ownerWallet = Wallet 1 -testCurrencyNames :: [TokenName] -testCurrencyNames = ["MOGUS", "USD"] +userWallets :: [Wallet] +userWallets = [Wallet i | i <- [2 .. 4]] + +testAssets :: [AssetClass] +testAssets = fmap toAsset ["MOGUS", "USD"] toAsset :: TokenName -> AssetClass toAsset tokenName = assetClass (scriptCurrencySymbol . FungibleToken.makeLiquidityPolicy $ tokenName) tokenName -testAssets :: [AssetClass] -testAssets = fmap toAsset testCurrencyNames - -initContract :: Contract (Monoid.Last [Oracle.Oracle]) BlockchainActions Text () -initContract = do +distributeFunds :: + [Wallet] -> + [AssetClass] -> + Contract () BlockchainActions Text () +distributeFunds wallets assets = do ownPK <- pubKeyHash <$> ownPubKey - let testCurrenciesValue = mconcat $ fmap (`assetClassValue` 1000) testAssets + let testCurrenciesValue = mconcat $ fmap (`assetClassValue` 1000) assets policyLookups = mconcat $ - fmap (Constraints.monetaryPolicy . FungibleToken.makeLiquidityPolicy . Prelude.snd . unAssetClass) testAssets + fmap (Constraints.monetaryPolicy . FungibleToken.makeLiquidityPolicy . Prelude.snd . unAssetClass) assets adaValue = lovelaceValueOf amount forM_ wallets $ \w -> do let pkh = pubKeyHash $ walletPubKey w @@ -85,7 +88,14 @@ initContract = do when (pkh /= ownPK) $ do ledgerTx <- submitTxConstraintsWith @Scripts.Any lookups tx void $ awaitTxConfirmed $ txId ledgerTx - oracles <- forM testAssets $ \asset -> do + where + amount = 1000000 + +createOracles :: + [AssetClass] -> + Contract (Monoid.Last [Oracle.Oracle]) BlockchainActions Text () +createOracles assets = do + oracles <- forM assets $ \asset -> do let oracleParams = Oracle.OracleParams { opFees = 0 , opSymbol = fst . unAssetClass $ asset @@ -95,29 +105,30 @@ initContract = do Oracle.updateOracle oracle oneAdaInLovelace pure oracle tell $ Monoid.Last $ Just oracles - where - amount = 1000000 data ContractIDs = ContractIDs { cidUser :: Map.Map Wallet ContractInstanceId, cidInfo :: ContractInstanceId } activateContracts :: Simulation (Builtin AaveContracts) ContractIDs activateContracts = do - cidInit <- Simulator.activateContract (Wallet 1) Init - oracles <- flip Simulator.waitForState cidInit $ \json -> case (fromJSON json :: Result (Monoid.Last [Oracle.Oracle])) of + cidFunds <- Simulator.activateContract ownerWallet $ DistributeFunds userWallets testAssets + _ <- Simulator.waitUntilFinished cidFunds + + cidOracles <- Simulator.activateContract ownerWallet $ CreateOracles testAssets + oracles <- flip Simulator.waitForState cidOracles $ \json -> case (fromJSON json :: Result (Monoid.Last [Oracle.Oracle])) of Success (Monoid.Last (Just res)) -> Just res _ -> Nothing Simulator.logString @(Builtin AaveContracts) "Initialization finished." - let params = fmap (\o -> Aave.CreateParams (Oracle.oAsset o) o) oracles - cidStart <- Simulator.activateContract (Wallet 1) (AaveStart params) - aa <- flip Simulator.waitForState cidStart $ \json -> case (fromJSON json :: Result (Monoid.Last (Either Text Aave.Aave))) of - Success (Monoid.Last (Just (Right aa))) -> Just aa - _ -> Nothing + cidStart <- Simulator.activateContract ownerWallet AaveStart + _ <- Simulator.callEndpointOnInstance cidStart "start" $ fmap (\o -> Aave.CreateParams (Oracle.oAsset o) o) oracles + aa <- flip Simulator.waitForState cidStart $ \json -> case (fromJSON json :: Result (Monoid.Last (ContractResponse Text Aave.OwnerContractState))) of + Success (Monoid.Last (Just (ContractSuccess (Aave.Started aa)))) -> Just aa + _ -> Nothing Simulator.logString @(Builtin AaveContracts) $ "Aave instance created: " ++ show aa - cidInfo <- Simulator.activateContract (Wallet 1) $ AaveInfo aa + cidInfo <- Simulator.activateContract ownerWallet $ AaveInfo aa - cidUser <- fmap Map.fromList $ forM (tail wallets) $ \w -> do + cidUser <- fmap Map.fromList $ forM userWallets $ \w -> do cid <- Simulator.activateContract w $ AaveUser aa Simulator.logString @(Builtin AaveContracts) $ "Aave user contract started for " ++ show w return (w, cid) @@ -232,8 +243,9 @@ runLendingPoolSimulation = void $ Simulator.runSimulationWith handlers $ do shutdown data AaveContracts = - Init - | AaveStart [Aave.CreateParams] + DistributeFunds [Wallet] [AssetClass] + | CreateOracles [AssetClass] + | AaveStart | AaveInfo Aave.Aave | AaveUser Aave.Aave deriving (Eq, Show, Generic) @@ -252,13 +264,15 @@ handleAaveContract = Builtin.handleBuiltin getSchema getContract where getSchema = \case AaveUser _ -> Builtin.endpointsToSchemas @(Aave.AaveUserSchema .\\ BlockchainActions) AaveInfo _ -> Builtin.endpointsToSchemas @(Aave.AaveInfoSchema .\\ BlockchainActions) - AaveStart _ -> Builtin.endpointsToSchemas @(Aave.AaveOwnerSchema .\\ BlockchainActions) - Init -> Builtin.endpointsToSchemas @Empty + AaveStart -> Builtin.endpointsToSchemas @(Aave.AaveOwnerSchema .\\ BlockchainActions) + DistributeFunds _ _ -> Builtin.endpointsToSchemas @Empty + CreateOracles _ -> Builtin.endpointsToSchemas @Empty getContract = \case - AaveInfo aave -> SomeBuiltin $ Aave.infoEndpoints aave - AaveUser aave -> SomeBuiltin $ Aave.userEndpoints aave - AaveStart params -> SomeBuiltin $ Aave.ownerEndpoint params - Init -> SomeBuiltin initContract + AaveInfo aave -> SomeBuiltin $ Aave.infoEndpoints aave + AaveUser aave -> SomeBuiltin $ Aave.userEndpoints aave + AaveStart -> SomeBuiltin Aave.ownerEndpoints + DistributeFunds wallets assets -> SomeBuiltin $ distributeFunds wallets assets + CreateOracles assets -> SomeBuiltin $ createOracles assets handlers :: SimulatorEffectHandlers (Builtin AaveContracts) handlers = diff --git a/MetaLamp/lending-pool/test/Fixtures.hs b/MetaLamp/lending-pool/test/Fixtures.hs new file mode 100644 index 000000000..50346037d --- /dev/null +++ b/MetaLamp/lending-pool/test/Fixtures.hs @@ -0,0 +1,6 @@ +module Fixtures (module Fixtures.Aave, module Fixtures.Asset, module Fixtures.Init, module Fixtures.Wallet) where + +import Fixtures.Aave +import Fixtures.Asset +import Fixtures.Init +import Fixtures.Wallet diff --git a/MetaLamp/lending-pool/test/Fixtures/Aave.hs b/MetaLamp/lending-pool/test/Fixtures/Aave.hs new file mode 100644 index 000000000..4b5ea3be9 --- /dev/null +++ b/MetaLamp/lending-pool/test/Fixtures/Aave.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Fixtures.Aave where + +import Data.Text (Text) +import Fixtures.Symbol (forgeSymbol, getSymbol) +import qualified Ledger +import Plutus.Contract +import qualified Plutus.Contracts.Core as Aave +import qualified Plutus.Contracts.Endpoints as Aave +import qualified Plutus.Contracts.TxUtils as TxUtils +import Plutus.V1.Ledger.Value (CurrencySymbol) +import PlutusTx.Prelude + +aaveSymbol :: CurrencySymbol +aaveSymbol = getSymbol Aave.aaveProtocolName + +aaveAddress :: Ledger.Address +aaveAddress = Aave.aaveAddress . Aave.aave $ aaveSymbol + +aave :: Aave.Aave +aave = Aave.aave aaveSymbol + +aaveHash :: Ledger.ValidatorHash +aaveHash = Aave.aaveHash aave + +start :: [Aave.CreateParams] -> Contract () Aave.AaveOwnerSchema Text Aave.Aave +start = Aave.start' (forgeSymbol Aave.aaveProtocolName) diff --git a/MetaLamp/lending-pool/test/Fixtures/Asset.hs b/MetaLamp/lending-pool/test/Fixtures/Asset.hs new file mode 100644 index 000000000..e5e206487 --- /dev/null +++ b/MetaLamp/lending-pool/test/Fixtures/Asset.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Fixtures.Asset where + +import qualified Fixtures.Aave as AaveMock +import qualified Plutus.Contracts.AToken as AToken +import Plutus.PAB.Simulation (toAsset) +import Plutus.V1.Ledger.Value (AssetClass) + +mogus :: AssetClass +mogus = toAsset "MOGUS" + +usd :: AssetClass +usd = toAsset "USD" + +defaultAssets :: [AssetClass] +defaultAssets = [mogus, usd] + +amogus :: AssetClass +amogus = AToken.makeAToken AaveMock.aaveHash mogus + +ausd :: AssetClass +ausd = AToken.makeAToken AaveMock.aaveHash usd diff --git a/MetaLamp/lending-pool/test/Fixtures/Init.hs b/MetaLamp/lending-pool/test/Fixtures/Init.hs new file mode 100644 index 000000000..d7a4e2c32 --- /dev/null +++ b/MetaLamp/lending-pool/test/Fixtures/Init.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Fixtures.Init where + +import Control.Monad (forM, forM_, void) +import qualified Data.Map as Map +import Data.Monoid (Last (..)) +import Data.Text (Text) +import Data.Void (Void) +import qualified Fixtures.Aave as AaveMock +import Fixtures.Asset (defaultAssets) +import Fixtures.Symbol (forgeSymbol, getSymbol) +import Fixtures.Wallet (ownerWallet, userWallets) +import Plutus.Contract +import qualified Plutus.Contracts.Core as Aave +import Plutus.Contracts.Endpoints (ContractResponse (..)) +import qualified Plutus.Contracts.Endpoints as Aave +import qualified Plutus.Contracts.Oracle as Oracle +import Plutus.PAB.Simulation (distributeFunds) +import qualified Plutus.Trace.Emulator as Trace +import Plutus.V1.Ledger.Ada (lovelaceValueOf) +import Plutus.V1.Ledger.Crypto (PubKeyHash (..)) +import Plutus.V1.Ledger.Value (AssetClass (..), Value, + assetClassValue) +import qualified PlutusTx.AssocMap as AssocMap +import Utils.Data (getPubKey) +import Wallet.Emulator.Wallet (Wallet) + +oracles :: [Oracle.Oracle] +oracles = fmap + (\asset -> + Oracle.Oracle + { + Oracle.oSymbol = getSymbol Oracle.oracleTokenName, + Oracle.oOperator = getPubKey ownerWallet, + Oracle.oFee = 0, + Oracle.oAsset = asset }) + defaultAssets + +startParams :: [Aave.CreateParams] +startParams = fmap (\o -> Aave.CreateParams (Oracle.oAsset o) o) oracles + +initialUsers :: AssocMap.Map (AssetClass, PubKeyHash) Aave.UserConfig +initialUsers = AssocMap.empty + +initialReserves :: AssocMap.Map AssetClass Aave.Reserve +initialReserves = AssocMap.fromList (fmap (\params -> (Aave.cpAsset params, Aave.createReserve AaveMock.aave params)) startParams) + +initialFunds :: Value +initialFunds = lovelaceValueOf 1000000 <> mconcat ((`assetClassValue` 1000) <$> defaultAssets) + +startContract :: Contract () Aave.AaveOwnerSchema Text () +startContract = void $ AaveMock.start startParams + +userContract :: Contract (Last (ContractResponse Text Aave.UserContractState)) Aave.AaveUserSchema Void () +userContract = void $ Aave.userEndpoints AaveMock.aave + +distributeTrace :: Trace.EmulatorTrace () +distributeTrace = do + _ <- Trace.activateContractWallet ownerWallet $ distributeFunds userWallets defaultAssets + _ <- Trace.waitNSlots 5 + pure () + +startTrace :: Trace.EmulatorTrace () +startTrace = do + _ <- Trace.activateContractWallet ownerWallet startContract + _ <- Trace.waitNSlots 5 + pure () + +startOracles :: Contract () BlockchainActions Text () +startOracles = forM_ oracles + (\oracle -> do + _ <- forgeSymbol Oracle.oracleTokenName + Oracle.updateOracle oracle 1000000 + ) + +oracleTrace :: Trace.EmulatorTrace () +oracleTrace = do + _ <- Trace.activateContractWallet ownerWallet startOracles + _ <- Trace.waitNSlots 5 + pure () + +type UserHandle = Trace.ContractHandle (Last (ContractResponse Text Aave.UserContractState)) Aave.AaveUserSchema Void + +defaultTrace :: Trace.EmulatorTrace (Map.Map Wallet UserHandle) +defaultTrace = do + _ <- distributeTrace + _ <- oracleTrace + _ <- startTrace + fmap Map.fromList $ forM userWallets $ \wallet -> do + handle <- Trace.activateContractWallet wallet userContract + pure (wallet, handle) diff --git a/MetaLamp/lending-pool/test/Fixtures/Symbol.hs b/MetaLamp/lending-pool/test/Fixtures/Symbol.hs new file mode 100644 index 000000000..f7112a897 --- /dev/null +++ b/MetaLamp/lending-pool/test/Fixtures/Symbol.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module Fixtures.Symbol where + +import Control.Monad (void) +import Data.Text (Text) +import Data.Void (Void) +import qualified Ledger +import qualified Ledger.Constraints as Constraints +import Ledger.Typed.Scripts (MonetaryPolicy) +import qualified Ledger.Typed.Scripts as Scripts +import Plutus.Contract +import qualified Plutus.Contracts.TxUtils as TxUtils +import Plutus.V1.Ledger.Contexts (ScriptContext) +import qualified Plutus.V1.Ledger.Scripts as Scripts +import Plutus.V1.Ledger.Value (CurrencySymbol, TokenName, + assetClass, assetClassValue) +import qualified PlutusTx + +{-# INLINABLE validator #-} +validator :: TokenName -> ScriptContext -> Bool +validator _ _ = True + +makePolicy :: TokenName -> MonetaryPolicy +makePolicy tokenName = Scripts.mkMonetaryPolicyScript $ + $$(PlutusTx.compile [|| Scripts.wrapMonetaryPolicy . validator ||]) + `PlutusTx.applyCode` + PlutusTx.liftCode tokenName + +getSymbol :: TokenName -> CurrencySymbol +getSymbol = Ledger.scriptCurrencySymbol . makePolicy + +forgeSymbol :: HasBlockchainActions s => TokenName -> Contract () s Text CurrencySymbol +forgeSymbol tokenName = do + pkh <- Ledger.pubKeyHash <$> ownPubKey + let symbol = getSymbol tokenName + forgeValue = assetClassValue (assetClass symbol tokenName) 1 + ledgerTx <- + TxUtils.submitTxPair $ + TxUtils.mustForgeValue @Void (makePolicy tokenName) forgeValue + <> (mempty, Constraints.mustPayToPubKey pkh forgeValue) + void $ awaitTxConfirmed $ Ledger.txId ledgerTx + pure symbol diff --git a/MetaLamp/lending-pool/test/Fixtures/Wallet.hs b/MetaLamp/lending-pool/test/Fixtures/Wallet.hs new file mode 100644 index 000000000..c35e258e7 --- /dev/null +++ b/MetaLamp/lending-pool/test/Fixtures/Wallet.hs @@ -0,0 +1,15 @@ +module Fixtures.Wallet where + +import Wallet.Emulator.Wallet (Wallet (..)) + +ownerWallet :: Wallet +ownerWallet = Wallet 1 + +lenderWallet :: Wallet +lenderWallet = Wallet 2 + +borrowerWallet :: Wallet +borrowerWallet = Wallet 3 + +userWallets :: [Wallet] +userWallets = [lenderWallet, borrowerWallet] diff --git a/MetaLamp/lending-pool/test/Main.hs b/MetaLamp/lending-pool/test/Main.hs new file mode 100644 index 000000000..f3e4fcfb4 --- /dev/null +++ b/MetaLamp/lending-pool/test/Main.hs @@ -0,0 +1,28 @@ +module Main(main) where + +import qualified Spec.Borrow +import qualified Spec.Deposit +import qualified Spec.ProvideCollateral +import qualified Spec.Repay +import qualified Spec.RevokeCollateral +import qualified Spec.Start +import qualified Spec.Withdraw +import Test.Tasty +import Test.Tasty.Hedgehog (HedgehogTestLimit (..)) + +main :: IO () +main = defaultMain tests + +limit :: HedgehogTestLimit +limit = HedgehogTestLimit (Just 5) + +tests :: TestTree +tests = localOption limit $ testGroup "lending pool tests" [ + Spec.Start.tests, + Spec.Deposit.tests, + Spec.Withdraw.tests, + Spec.ProvideCollateral.tests, + Spec.RevokeCollateral.tests, + Spec.Borrow.tests, + Spec.Repay.tests + ] diff --git a/MetaLamp/lending-pool/test/Spec/Borrow.hs b/MetaLamp/lending-pool/test/Spec/Borrow.hs new file mode 100644 index 000000000..4e9ce0878 --- /dev/null +++ b/MetaLamp/lending-pool/test/Spec/Borrow.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Spec.Borrow where + +import Control.Lens (over) +import qualified Data.Map as Map +import qualified Fixtures +import Plutus.Contract.Test +import qualified Plutus.Contracts.Core as Aave +import qualified Plutus.Contracts.Endpoints as Aave +import qualified Plutus.Trace.Emulator as Trace +import Plutus.V1.Ledger.Value (AssetClass, assetClassValue) +import qualified PlutusTx.AssocMap as AssocMap +import Spec.Deposit (deposit) +import Spec.ProvideCollateral (provideCollateral) +import qualified Spec.Shared as Shared +import Test.Tasty +import qualified Utils.Data as Utils + +tests :: TestTree +tests = testGroup "borrow" [ + checkPredicate + "Should succeed if user's collateral is sufficient" + (walletFundsChange + Fixtures.lenderWallet + (Fixtures.initialFunds <> + assetClassValue Fixtures.usd (negate 100) <> assetClassValue Fixtures.ausd 100) + .&&. + walletFundsChange + Fixtures.borrowerWallet + (Fixtures.initialFunds <> + assetClassValue Fixtures.mogus (negate 100) <> assetClassValue Fixtures.usd 50) + .&&. Shared.reservesChange ( + Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus + . Utils.modifyAt (over Aave._rAmount (subtract 50 . (+100))) Fixtures.usd $ Fixtures.initialReserves) + .&&. Shared.userConfigsChange + ( + AssocMap.insert + (Fixtures.usd, Utils.getPubKey Fixtures.borrowerWallet) + (Aave.UserConfig { Aave.ucDebt = 50, Aave.ucCollateralizedInvestment = 0 }) + . + AssocMap.insert + (Fixtures.mogus, Utils.getPubKey Fixtures.borrowerWallet) + (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 100 }) + . + AssocMap.insert + (Fixtures.usd, Utils.getPubKey Fixtures.lenderWallet) + (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 0 }) + $ Fixtures.initialUsers + ) + ) + $ do + handles <- Fixtures.defaultTrace + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.usd 100 + + deposit (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.mogus 100 + provideCollateral (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.mogus 100 + borrow (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.usd 50, + checkPredicate + "Should fail if user's collateral is insufficient" + (walletFundsChange Fixtures.lenderWallet Fixtures.initialFunds + .&&. walletFundsChange Fixtures.borrowerWallet Fixtures.initialFunds + .&&. Shared.reservesChange Fixtures.initialReserves + .&&. Shared.userConfigsChange Fixtures.initialUsers + .&&. assertAccumState Fixtures.userContract (Trace.walletInstanceTag Fixtures.lenderWallet) Utils.isLastError "Contract last state is an error" + ) + $ do + handles <- Fixtures.defaultTrace + borrow (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.usd 100 + ] + +borrow :: Fixtures.UserHandle -> Wallet -> AssetClass -> Integer -> Trace.EmulatorTrace () +borrow userHandle wallet asset amount = do + Trace.callEndpoint @"borrow" userHandle $ Aave.BorrowParams asset amount (Utils.getPubKey wallet) + _ <- Trace.waitNSlots 3 + pure () diff --git a/MetaLamp/lending-pool/test/Spec/Deposit.hs b/MetaLamp/lending-pool/test/Spec/Deposit.hs new file mode 100644 index 000000000..8b1912c08 --- /dev/null +++ b/MetaLamp/lending-pool/test/Spec/Deposit.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Spec.Deposit where + +import Control.Lens (over) +import qualified Data.Map as Map +import qualified Fixtures +import Plutus.Contract.Test +import qualified Plutus.Contracts.Core as Aave +import qualified Plutus.Contracts.Endpoints as Aave +import qualified Plutus.Trace.Emulator as Trace +import Plutus.V1.Ledger.Value (AssetClass, assetClassValue) +import qualified PlutusTx.AssocMap as AssocMap +import qualified Spec.Shared as Shared +import Test.Tasty +import qualified Utils.Data as Utils + +tests :: TestTree +tests = testGroup "deposit" [ + checkPredicate + "Should succeed if user's wallet balance is sufficient" + (walletFundsChange + Fixtures.lenderWallet + (Fixtures.initialFunds <> + assetClassValue Fixtures.mogus (negate 100) <> assetClassValue Fixtures.amogus 100) + .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus Fixtures.initialReserves) + .&&. Shared.userConfigsChange + ( + AssocMap.insert + (Fixtures.mogus, Utils.getPubKey Fixtures.lenderWallet) + (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 0 }) + $ Fixtures.initialUsers + ) + ) + $ do + handles <- Fixtures.defaultTrace + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100, + checkPredicate + "Should fail if user's wallet balance is insufficient" + (walletFundsChange Fixtures.lenderWallet Fixtures.initialFunds + .&&. Shared.reservesChange Fixtures.initialReserves + .&&. Shared.userConfigsChange Fixtures.initialUsers + .&&. assertAccumState Fixtures.userContract (Trace.walletInstanceTag Fixtures.lenderWallet) Utils.isLastError "Contract last state is an error" + ) + $ do + handles <- Fixtures.defaultTrace + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 10000 + ] + +deposit :: Fixtures.UserHandle -> Wallet -> AssetClass -> Integer -> Trace.EmulatorTrace () +deposit userHandle wallet asset amount = do + Trace.callEndpoint @"deposit" userHandle $ Aave.DepositParams asset (Utils.getPubKey wallet) amount + _ <- Trace.waitNSlots 3 + pure () diff --git a/MetaLamp/lending-pool/test/Spec/ProvideCollateral.hs b/MetaLamp/lending-pool/test/Spec/ProvideCollateral.hs new file mode 100644 index 000000000..2781bf2c0 --- /dev/null +++ b/MetaLamp/lending-pool/test/Spec/ProvideCollateral.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Spec.ProvideCollateral where + +import Control.Lens (over) +import qualified Data.Map as Map +import qualified Fixtures +import Plutus.Contract.Test +import qualified Plutus.Contracts.Core as Aave +import qualified Plutus.Contracts.Endpoints as Aave +import qualified Plutus.Trace.Emulator as Trace +import Plutus.V1.Ledger.Value (AssetClass, assetClassValue) +import qualified PlutusTx.AssocMap as AssocMap +import Spec.Deposit (deposit) +import qualified Spec.Shared as Shared +import Test.Tasty +import qualified Utils.Data as Utils + +tests :: TestTree +tests = testGroup "provideCollateral" [ + checkPredicate + "Should succeed if user's aToken balance is sufficient" + (walletFundsChange + Fixtures.lenderWallet + (Fixtures.initialFunds <> + assetClassValue Fixtures.mogus (negate 100)) + .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus Fixtures.initialReserves) + .&&. Shared.userConfigsChange + (AssocMap.insert + (Fixtures.mogus, Utils.getPubKey Fixtures.lenderWallet) + (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 100 }) + Fixtures.initialUsers) + ) + $ do + handles <- Fixtures.defaultTrace + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 + provideCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100, + checkPredicate + "Should fail if user's aToken balance is insufficient" + (walletFundsChange Fixtures.lenderWallet Fixtures.initialFunds + .&&. Shared.reservesChange Fixtures.initialReserves + .&&. Shared.userConfigsChange Fixtures.initialUsers + .&&. assertAccumState Fixtures.userContract (Trace.walletInstanceTag Fixtures.lenderWallet) Utils.isLastError "Contract last state is an error" + ) + $ do + handles <- Fixtures.defaultTrace + provideCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 + ] + +provideCollateral :: Fixtures.UserHandle -> Wallet -> AssetClass -> Integer -> Trace.EmulatorTrace () +provideCollateral userHandle wallet asset amount = do + Trace.callEndpoint @"provideCollateral" userHandle $ Aave.ProvideCollateralParams asset amount (Utils.getPubKey wallet) + _ <- Trace.waitNSlots 3 + pure () diff --git a/MetaLamp/lending-pool/test/Spec/Repay.hs b/MetaLamp/lending-pool/test/Spec/Repay.hs new file mode 100644 index 000000000..d6a4c3993 --- /dev/null +++ b/MetaLamp/lending-pool/test/Spec/Repay.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Spec.Repay where + +import Control.Lens (over) +import qualified Data.Map as Map +import qualified Fixtures +import Plutus.Contract.Test +import qualified Plutus.Contracts.Core as Aave +import qualified Plutus.Contracts.Endpoints as Aave +import qualified Plutus.Trace.Emulator as Trace +import Plutus.V1.Ledger.Value (AssetClass, assetClassValue) +import qualified PlutusTx.AssocMap as AssocMap +import Spec.Borrow (borrow) +import Spec.Deposit (deposit) +import Spec.ProvideCollateral (provideCollateral) +import qualified Spec.Shared as Shared +import Test.Tasty +import qualified Utils.Data as Utils + +tests :: TestTree +tests = testGroup "repay" [ + checkPredicate + "Should succeed if user has a debt and funds to pay" + (walletFundsChange + Fixtures.lenderWallet + (Fixtures.initialFunds <> + assetClassValue Fixtures.usd (negate 100) <> assetClassValue Fixtures.ausd 100) + .&&. + walletFundsChange + Fixtures.borrowerWallet + (Fixtures.initialFunds <> + assetClassValue Fixtures.mogus (negate 100) <> assetClassValue Fixtures.usd (50 - 25)) + .&&. Shared.reservesChange ( + Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus + . Utils.modifyAt (over Aave._rAmount ((+25) . subtract 50 . (+100))) Fixtures.usd $ Fixtures.initialReserves) + .&&. Shared.userConfigsChange + ( + AssocMap.insert + (Fixtures.usd, Utils.getPubKey Fixtures.borrowerWallet) + (Aave.UserConfig { Aave.ucDebt = 50 - 25, Aave.ucCollateralizedInvestment = 0 }) + . + AssocMap.insert + (Fixtures.mogus, Utils.getPubKey Fixtures.borrowerWallet) + (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 100 }) + . + AssocMap.insert + (Fixtures.usd, Utils.getPubKey Fixtures.lenderWallet) + (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 0 }) + $ Fixtures.initialUsers + ) + ) + $ do + handles <- Fixtures.defaultTrace + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.usd 100 + + deposit (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.mogus 100 + provideCollateral (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.mogus 100 + borrow (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.usd 50 + repay (handles Map.! Fixtures.borrowerWallet) Fixtures.borrowerWallet Fixtures.usd 25 + , + checkPredicate + "Should fail if user has no debt" + (walletFundsChange Fixtures.lenderWallet Fixtures.initialFunds + .&&. walletFundsChange Fixtures.borrowerWallet Fixtures.initialFunds + .&&. Shared.reservesChange Fixtures.initialReserves + .&&. Shared.userConfigsChange Fixtures.initialUsers + .&&. assertAccumState Fixtures.userContract (Trace.walletInstanceTag Fixtures.lenderWallet) Utils.isLastError "Contract last state is an error" + ) + $ do + handles <- Fixtures.defaultTrace + repay (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.usd 100 + ] + +repay :: Fixtures.UserHandle -> Wallet -> AssetClass -> Integer -> Trace.EmulatorTrace () +repay userHandle wallet asset amount = do + Trace.callEndpoint @"repay" userHandle $ Aave.RepayParams asset amount (Utils.getPubKey wallet) + _ <- Trace.waitNSlots 3 + pure () diff --git a/MetaLamp/lending-pool/test/Spec/RevokeCollateral.hs b/MetaLamp/lending-pool/test/Spec/RevokeCollateral.hs new file mode 100644 index 000000000..481b47f78 --- /dev/null +++ b/MetaLamp/lending-pool/test/Spec/RevokeCollateral.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Spec.RevokeCollateral where + +import Control.Lens (over) +import qualified Data.Map as Map +import qualified Fixtures +import Plutus.Contract.Test +import qualified Plutus.Contracts.Core as Aave +import qualified Plutus.Contracts.Endpoints as Aave +import qualified Plutus.Trace.Emulator as Trace +import Plutus.V1.Ledger.Value (AssetClass, assetClassValue) +import qualified PlutusTx.AssocMap as AssocMap +import Spec.Deposit (deposit) +import Spec.ProvideCollateral (provideCollateral) +import qualified Spec.Shared as Shared +import Test.Tasty +import qualified Utils.Data as Utils + +tests :: TestTree +tests = testGroup "revokeCollateral" [ + checkPredicate + "Should succeed if user's investment is sufficient" + (walletFundsChange + Fixtures.lenderWallet + (Fixtures.initialFunds <> + assetClassValue Fixtures.mogus (negate 100) <> assetClassValue Fixtures.amogus (100 - 100 + 50)) + .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus Fixtures.initialReserves) + .&&. Shared.userConfigsChange + (AssocMap.insert + (Fixtures.mogus, Utils.getPubKey Fixtures.lenderWallet) + (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 50 }) + Fixtures.initialUsers) + ) + $ do + handles <- Fixtures.defaultTrace + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 + provideCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 + revokeCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 50, + checkPredicate + "Should fail if user's investment is insufficient" + (walletFundsChange Fixtures.lenderWallet Fixtures.initialFunds + .&&. Shared.reservesChange Fixtures.initialReserves + .&&. Shared.userConfigsChange Fixtures.initialUsers + .&&. assertAccumState Fixtures.userContract (Trace.walletInstanceTag Fixtures.lenderWallet) Utils.isLastError "Contract last state is an error" + ) + $ do + handles <- Fixtures.defaultTrace + revokeCollateral (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 + ] + +revokeCollateral :: Fixtures.UserHandle -> Wallet -> AssetClass -> Integer -> Trace.EmulatorTrace () +revokeCollateral userHandle wallet asset amount = do + Trace.callEndpoint @"revokeCollateral" userHandle $ Aave.RevokeCollateralParams asset amount (Utils.getPubKey wallet) + _ <- Trace.waitNSlots 3 + pure () diff --git a/MetaLamp/lending-pool/test/Spec/Shared.hs b/MetaLamp/lending-pool/test/Spec/Shared.hs new file mode 100644 index 000000000..19bb98e98 --- /dev/null +++ b/MetaLamp/lending-pool/test/Spec/Shared.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Spec.Shared where + +import qualified Fixtures +import Plutus.Contract.Test (TracePredicate) +import qualified Plutus.Contracts.Core as Aave +import Plutus.V1.Ledger.Crypto (PubKeyHash) +import Plutus.V1.Ledger.Value (AssetClass) +import qualified PlutusTx.AssocMap as AssocMap +import qualified Utils.Data as Utils +import qualified Utils.Trace as Utils + +reservesChange :: AssocMap.Map AssetClass Aave.Reserve -> TracePredicate +reservesChange reserves = Utils.datumsAtAddress Fixtures.aaveAddress (Utils.one check) + where + check (Aave.ReservesDatum _ reserves') = reserves' == reserves + check _ = False + +userConfigsChange :: AssocMap.Map (AssetClass, PubKeyHash) Aave.UserConfig -> TracePredicate +userConfigsChange configs = Utils.datumsAtAddress Fixtures.aaveAddress (Utils.one check) + where + check (Aave.UserConfigsDatum _ configs') = configs' == configs + check _ = False diff --git a/MetaLamp/lending-pool/test/Spec/Start.hs b/MetaLamp/lending-pool/test/Spec/Start.hs new file mode 100644 index 000000000..bdcf491e7 --- /dev/null +++ b/MetaLamp/lending-pool/test/Spec/Start.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} + +module Spec.Start where + +import qualified Fixtures +import Plutus.Contract.Test +import qualified Plutus.Contracts.Core as Aave +import Test.Tasty +import qualified Utils.Data as Utils +import qualified Utils.Trace as Utils + +tests :: TestTree +tests = testGroup "start" [checkPredicate + "Should start a new lending pool with a set of available currencies" + (Utils.datumsAtAddress Fixtures.aaveAddress startDatumValid) + Fixtures.startTrace] + +startDatumValid :: [Aave.AaveDatum] -> Bool +startDatumValid = Utils.allSatisfy . fmap Utils.one $ [hasReserves, hasUsers, hasOperator] + where + hasOperator (Aave.LendingPoolDatum _) = True + hasOperator _ = False + hasReserves (Aave.ReservesDatum _ reserves) = + reserves == Fixtures.initialReserves + hasReserves _ = False + hasUsers (Aave.UserConfigsDatum _ users) = users == Fixtures.initialUsers + hasUsers _ = False diff --git a/MetaLamp/lending-pool/test/Spec/Withdraw.hs b/MetaLamp/lending-pool/test/Spec/Withdraw.hs new file mode 100644 index 000000000..a130ae3e3 --- /dev/null +++ b/MetaLamp/lending-pool/test/Spec/Withdraw.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Spec.Withdraw where + +import Control.Lens (over) +import qualified Data.Map as Map +import qualified Fixtures +import Plutus.Contract.Test +import qualified Plutus.Contracts.Core as Aave +import qualified Plutus.Contracts.Endpoints as Aave +import qualified Plutus.Trace.Emulator as Trace +import Plutus.V1.Ledger.Value (AssetClass, assetClassValue) +import qualified PlutusTx.AssocMap as AssocMap +import Spec.Deposit (deposit) +import qualified Spec.Shared as Shared +import Test.Tasty +import qualified Utils.Data as Utils + +tests :: TestTree +tests = testGroup "withdraw" [ + checkPredicate + "Should succeed if user's protocol balance is sufficient" + (walletFundsChange + Fixtures.lenderWallet + (Fixtures.initialFunds <> + assetClassValue Fixtures.mogus (negate 100 + 50) <> assetClassValue Fixtures.amogus (100 - 50)) + .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (subtract 50 . (+100))) Fixtures.mogus Fixtures.initialReserves) + .&&. Shared.userConfigsChange + ( + AssocMap.insert + (Fixtures.mogus, Utils.getPubKey Fixtures.lenderWallet) + (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 0 }) + $ Fixtures.initialUsers + ) + ) + $ do + handles <- Fixtures.defaultTrace + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 + withdraw (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 50, + checkPredicate + "Should fail if user's protocol balance is insufficient" + (walletFundsChange Fixtures.lenderWallet (Fixtures.initialFunds <> + assetClassValue Fixtures.mogus (negate 100) <> assetClassValue Fixtures.amogus 100) + .&&. Shared.reservesChange (Utils.modifyAt (over Aave._rAmount (+100)) Fixtures.mogus Fixtures.initialReserves) + .&&. Shared.userConfigsChange + ( + AssocMap.insert + (Fixtures.mogus, Utils.getPubKey Fixtures.lenderWallet) + (Aave.UserConfig { Aave.ucDebt = 0, Aave.ucCollateralizedInvestment = 0 }) + $ Fixtures.initialUsers + ) + .&&. assertAccumState Fixtures.userContract (Trace.walletInstanceTag Fixtures.lenderWallet) Utils.isLastError "Contract last state is an error" + ) + $ do + handles <- Fixtures.defaultTrace + deposit (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 100 + withdraw (handles Map.! Fixtures.lenderWallet) Fixtures.lenderWallet Fixtures.mogus 200 + ] + +withdraw :: Fixtures.UserHandle -> Wallet -> AssetClass -> Integer -> Trace.EmulatorTrace () +withdraw userHandle wallet asset amount = do + Trace.callEndpoint @"withdraw" userHandle $ Aave.WithdrawParams asset (Utils.getPubKey wallet) amount + _ <- Trace.waitNSlots 3 + pure () diff --git a/MetaLamp/lending-pool/test/Utils/Data.hs b/MetaLamp/lending-pool/test/Utils/Data.hs new file mode 100644 index 000000000..1e5f01832 --- /dev/null +++ b/MetaLamp/lending-pool/test/Utils/Data.hs @@ -0,0 +1,27 @@ +module Utils.Data where + +import Data.Function ((&)) +import Data.Monoid (Last (..)) +import Plutus.Contracts.Endpoints (ContractResponse (..)) +import Plutus.V1.Ledger.Crypto (PubKeyHash, pubKeyHash) +import qualified PlutusTx.AssocMap as AssocMap +import qualified PlutusTx.Prelude as PlutusTx +import Wallet.Emulator.Wallet (Wallet, walletPubKey) + +allSatisfy :: [a -> Bool] -> a -> Bool +allSatisfy fs a = and . fmap (a &) $ fs + +one :: (a -> Bool) -> [a] -> Bool +one f = foldr reducer False + where + reducer cur acc = if acc then not . f $ cur else f cur + +modifyAt :: PlutusTx.Eq k => (v -> v) -> k -> AssocMap.Map k v -> AssocMap.Map k v +modifyAt f k m = maybe m (\v -> AssocMap.insert k (f v) m) (AssocMap.lookup k m) + +isLastError :: Last (ContractResponse e a) -> Bool +isLastError (Last (Just (ContractError _))) = True +isLastError _ = False + +getPubKey :: Wallet -> PubKeyHash +getPubKey = pubKeyHash . walletPubKey diff --git a/MetaLamp/lending-pool/test/Utils/Trace.hs b/MetaLamp/lending-pool/test/Utils/Trace.hs new file mode 100644 index 000000000..6c8a1d90a --- /dev/null +++ b/MetaLamp/lending-pool/test/Utils/Trace.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Utils.Trace where + +import qualified Control.Foldl as L +import Control.Monad (unless) +import Control.Monad.Freer.Error (throwError) +import Control.Monad.Freer.Writer (tell) +import qualified Data.Aeson as JSON + +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import Data.Monoid (Last (..)) +import Data.String (fromString) +import Data.Text.Prettyprint.Doc (Doc) +import Data.Void (Void) +import Ledger (Address) +import qualified Ledger +import Ledger.AddressMap (UtxoMap) +import Plutus.Contract (HasBlockchainActions) +import Plutus.Contract.Test (TracePredicate) +import Plutus.Contracts.Endpoints (ContractResponse (..)) +import qualified Plutus.Trace.Emulator as Trace +import Plutus.Trace.Emulator.Types (EmulatorRuntimeError (..)) +import PlutusTx (IsData, fromData) +import qualified Wallet.Emulator.Folds as Folds +import Wallet.Emulator.MultiAgent (EmulatorEvent) + +getState :: + (Show a + , Show e + , HasBlockchainActions s + , Trace.ContractConstraints s + , JSON.FromJSON e + , JSON.FromJSON a + , JSON.ToJSON e + , JSON.ToJSON a + , JSON.FromJSON e' + ) + => (a -> Maybe b) -> + Trace.ContractHandle (Last (ContractResponse e a)) s e' -> + Trace.EmulatorTrace b +getState pick userHandle = do + res <- Trace.observableState userHandle + case res of + (Last (Just (ContractSuccess s))) -> maybe (throwError . GenericError $ "Unexpected state: " <> show s) pure (pick s) + (Last (Just (ContractError e))) -> throwError . GenericError .show $ e + s -> throwError . JSONDecodingError $ "Unexpected state: " <> show s + +utxoAtAddress :: Monad m => Address -> (UtxoMap -> m c)-> L.FoldM m EmulatorEvent c +utxoAtAddress address check = Folds.postMapM check (L.generalize $ Folds.utxoAtAddress address) + +datumsAtAddress :: (IsData a, Show a) => Address -> ([a] -> Bool) -> TracePredicate +datumsAtAddress address check = utxoAtAddress address $ \utxo -> do + let datums = getDatums utxo + result = check datums + unless result $ tell @(Doc Void) (fromString $ "Datum check failed: " <> show datums) + pure result + +getDatums :: IsData a => UtxoMap -> [a] +getDatums = mapMaybe findDatum . Map.elems + +findDatum :: PlutusTx.IsData a => Ledger.TxOutTx -> Maybe a +findDatum o = do + hash <- Ledger.txOutDatumHash $ Ledger.txOutTxOut o + (Ledger.Datum e) <- Map.lookup hash $ Ledger.txData $ Ledger.txOutTxTx o + PlutusTx.fromData e