diff --git a/MetaLamp/lending-pool/client/src/Business/Aave.purs b/MetaLamp/lending-pool/client/src/Business/Aave.purs index c17cc0ffa..8b4c56cec 100644 --- a/MetaLamp/lending-pool/client/src/Business/Aave.purs +++ b/MetaLamp/lending-pool/client/src/Business/Aave.purs @@ -10,7 +10,7 @@ import Data.Lens (Prism', preview) import Data.Maybe (Maybe, maybe) import Data.RawJson (RawJson(..)) import Foreign.Generic (class Decode, class Encode, decodeJSON) -import Plutus.Contracts.Endpoints (ContractResponse(..)) +import Plutus.Abstract.ContractResponse (ContractResponse(..)) import Plutus.PAB.Events.ContractInstanceState (PartiallyDecodedResponse(..)) import Plutus.PAB.Simulation (AaveContracts) import Plutus.PAB.Webserver.Types (ContractInstanceClientState(..)) diff --git a/MetaLamp/lending-pool/client/src/Business/AaveInfo.purs b/MetaLamp/lending-pool/client/src/Business/AaveInfo.purs index 881cf3859..f8d7753d7 100644 --- a/MetaLamp/lending-pool/client/src/Business/AaveInfo.purs +++ b/MetaLamp/lending-pool/client/src/Business/AaveInfo.purs @@ -8,8 +8,8 @@ import Data.Either (Either) import Data.Json.JsonTuple (JsonTuple) import Data.Maybe (Maybe) import Data.Newtype (class Newtype, unwrap) -import Plutus.Contracts.Core (Reserve, UserConfig) -import Plutus.Contracts.Endpoints (_FundsAt, _PoolFunds, _Reserves, _Users) +import Plutus.Contracts.LendingPool.OnChain.Core.Script (Reserve, UserConfig) +import Plutus.Contracts.LendingPool.OffChain.Info (_FundsAt, _PoolFunds, _Reserves, _Users) import Plutus.PAB.Simulation (AaveContracts, _AaveInfo) import Plutus.PAB.Webserver.Types (ContractInstanceClientState) import Plutus.V1.Ledger.Crypto (PubKeyHash) diff --git a/MetaLamp/lending-pool/client/src/Business/AaveUser.purs b/MetaLamp/lending-pool/client/src/Business/AaveUser.purs index fb0617bc0..16ef137c1 100644 --- a/MetaLamp/lending-pool/client/src/Business/AaveUser.purs +++ b/MetaLamp/lending-pool/client/src/Business/AaveUser.purs @@ -7,7 +7,7 @@ import Capability.PollContract (class PollContract, PollError) import Data.Either (Either) import Data.Maybe (Maybe) import Data.Newtype (class Newtype, unwrap) -import Plutus.Contracts.Endpoints (BorrowParams, ProvideCollateralParams, RevokeCollateralParams, DepositParams, RepayParams, WithdrawParams, _Borrowed, _Deposited, _GetPubKey, _GetPubKeyBalance, _Repaid, _Withdrawn, _CollateralProvided, _CollateralRevoked) +import Plutus.Contracts.LendingPool.OffChain.User (BorrowParams, ProvideCollateralParams, RevokeCollateralParams, DepositParams, RepayParams, WithdrawParams, _Borrowed, _Deposited, _GetPubKey, _GetPubKeyBalance, _Repaid, _Withdrawn, _CollateralProvided, _CollateralRevoked) import Plutus.PAB.Simulation (AaveContracts, _AaveUser) import Plutus.PAB.Webserver.Types (ContractInstanceClientState) import Plutus.V1.Ledger.Crypto (PubKeyHash) diff --git a/MetaLamp/lending-pool/client/src/Component/Contract.purs b/MetaLamp/lending-pool/client/src/Component/Contract.purs index a93727fd8..9d2c778f6 100644 --- a/MetaLamp/lending-pool/client/src/Component/Contract.purs +++ b/MetaLamp/lending-pool/client/src/Component/Contract.purs @@ -24,7 +24,7 @@ import Halogen as H import Halogen.HTML as HH import Network.RemoteData (RemoteData(..)) import Network.RemoteData as RD -import Plutus.Contracts.Endpoints (BorrowParams(..), DepositParams(..), RepayParams(..), WithdrawParams(..), ProvideCollateralParams(..), RevokeCollateralParams(..)) +import Plutus.Contracts.LendingPool.OffChain.User (BorrowParams(..), DepositParams(..), RepayParams(..), WithdrawParams(..), ProvideCollateralParams(..), RevokeCollateralParams(..)) import Plutus.V1.Ledger.Crypto (PubKeyHash) import Plutus.V1.Ledger.Value (AssetClass(..), TokenName(..), Value) import View.FundsTable (fundsTable) diff --git a/MetaLamp/lending-pool/client/src/Component/MainPage.purs b/MetaLamp/lending-pool/client/src/Component/MainPage.purs index c1f505b9b..5c6ccac86 100644 --- a/MetaLamp/lending-pool/client/src/Component/MainPage.purs +++ b/MetaLamp/lending-pool/client/src/Component/MainPage.purs @@ -28,7 +28,7 @@ import Halogen.HTML.Properties (classes) import Network.RemoteData (RemoteData(..)) import Network.RemoteData as RD import Network.RemoteData as RemoteData -import Plutus.Contracts.Core (Reserve(..), UserConfig) +import Plutus.Contracts.LendingPool.OnChain.Core.Script (Reserve(..), UserConfig) import Plutus.PAB.Simulation (AaveContracts) import Plutus.PAB.Webserver.Types (ContractInstanceClientState) import Plutus.V1.Ledger.Crypto (PubKeyHash) diff --git a/MetaLamp/lending-pool/client/src/View/ReserveInfo.purs b/MetaLamp/lending-pool/client/src/View/ReserveInfo.purs index c60a78003..ee42f6df7 100644 --- a/MetaLamp/lending-pool/client/src/View/ReserveInfo.purs +++ b/MetaLamp/lending-pool/client/src/View/ReserveInfo.purs @@ -3,7 +3,7 @@ module View.ReserveInfo where import Prelude import Data.BigInteger (BigInteger) import Halogen.HTML as HH -import Plutus.Contracts.Core (Reserve(..)) +import Plutus.Contracts.LendingPool.OnChain.Core.Script (Reserve(..)) import Plutus.V1.Ledger.Value (AssetClass) import View.Utils (assetName) diff --git a/MetaLamp/lending-pool/client/src/View/UsersTable.purs b/MetaLamp/lending-pool/client/src/View/UsersTable.purs index 093ec2d50..1427dd643 100644 --- a/MetaLamp/lending-pool/client/src/View/UsersTable.purs +++ b/MetaLamp/lending-pool/client/src/View/UsersTable.purs @@ -6,7 +6,7 @@ import Data.BigInteger (fromInt) import Data.Maybe (fromMaybe) import Data.Tuple (Tuple(..)) import Halogen.HTML as HH -import Plutus.Contracts.Core (UserConfig(..)) +import Plutus.Contracts.LendingPool.OnChain.Core.Script (UserConfig(..)) import Plutus.V1.Ledger.Value (AssetClass) import View.Utils (assetName) diff --git a/MetaLamp/lending-pool/generate-purs/AaveTypes.hs b/MetaLamp/lending-pool/generate-purs/AaveTypes.hs index 9289a39bd..47cc56afd 100644 --- a/MetaLamp/lending-pool/generate-purs/AaveTypes.hs +++ b/MetaLamp/lending-pool/generate-purs/AaveTypes.hs @@ -11,29 +11,33 @@ module AaveTypes where -import Control.Monad.Reader (MonadReader) -import Data.Proxy (Proxy (Proxy)) -import Language.PureScript.Bridge (BridgePart, - Language (Haskell), - PSType, SumType, - TypeInfo (TypeInfo), - buildBridge, equal, - genericShow, - haskType, mkSumType, - order, - psTypeParameters, - typeModule, - typeName, - writePSTypesWith, - (^==)) -import Language.PureScript.Bridge.Builder (BridgeData) -import Language.PureScript.Bridge.TypeParameters (A, E) +import Control.Monad.Reader (MonadReader) +import Data.Proxy (Proxy (Proxy)) +import Language.PureScript.Bridge (BridgePart, + Language (Haskell), + PSType, SumType, + TypeInfo (TypeInfo), + buildBridge, + equal, + genericShow, + haskType, + mkSumType, order, + psTypeParameters, + typeModule, + typeName, + writePSTypesWith, + (^==)) +import Language.PureScript.Bridge.Builder (BridgeData) +import Language.PureScript.Bridge.TypeParameters (A, E) import qualified PSGenerator.Common -import qualified Plutus.Contracts.Core as Aave -import qualified Plutus.Contracts.Endpoints as Aave -import qualified Plutus.Contracts.Oracle as Oracle -import Plutus.PAB.Simulation (AaveContracts (..)) -import Plutus.V1.Ledger.Value (AssetClass) +import Plutus.Abstract.ContractResponse (ContractResponse) +import qualified Plutus.Contracts.LendingPool.OffChain.Info as Aave +import qualified Plutus.Contracts.LendingPool.OffChain.Owner as Aave +import qualified Plutus.Contracts.LendingPool.OffChain.User as Aave +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Aave +import qualified Plutus.Contracts.Service.Oracle as Oracle +import Plutus.PAB.Simulation (AaveContracts (..)) +import Plutus.V1.Ledger.Value (AssetClass) ratioBridge :: BridgePart ratioBridge = do @@ -50,7 +54,7 @@ aaveTypes :: [SumType 'Haskell] aaveTypes = [ (equal <*> (genericShow <*> mkSumType)) (Proxy @AaveContracts) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.Aave) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Oracle.Oracle) - , (equal <*> (genericShow <*> mkSumType)) (Proxy @(Aave.ContractResponse E A)) + , (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractResponse E A)) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.CreateParams) , (order <*> (equal <*> (genericShow <*> mkSumType))) (Proxy @AssetClass) , (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.UserContractState) diff --git a/MetaLamp/lending-pool/generate-purs/Main.hs b/MetaLamp/lending-pool/generate-purs/Main.hs index 8797fa049..a3d528b2a 100644 --- a/MetaLamp/lending-pool/generate-purs/Main.hs +++ b/MetaLamp/lending-pool/generate-purs/Main.hs @@ -8,7 +8,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} module Main where diff --git a/MetaLamp/lending-pool/plutus-starter.cabal b/MetaLamp/lending-pool/plutus-starter.cabal index f4b62f512..919955258 100644 --- a/MetaLamp/lending-pool/plutus-starter.cabal +++ b/MetaLamp/lending-pool/plutus-starter.cabal @@ -23,7 +23,7 @@ maintainer: Your email library exposed-modules: - Plutus.Contracts.Endpoints Plutus.Contracts.FungibleToken Plutus.Contracts.AToken Plutus.Contracts.Core Plutus.Contracts.Oracle Plutus.Contracts.State Plutus.State.Select Plutus.State.Update Plutus.Contracts.TxUtils Plutus.OutputValue Ext.Plutus.Ledger.Contexts Plutus.PAB.Simulation + Plutus.Abstract.State Plutus.Abstract.State.Select Plutus.Abstract.State.Update Plutus.Abstract.ContractResponse Plutus.Abstract.OutputValue Plutus.Abstract.TxUtils Plutus.Contracts.Service.FungibleToken Plutus.Contracts.Service.Oracle Plutus.Contracts.LendingPool.OnChain.Core Plutus.Contracts.LendingPool.OnChain.Core.Script Plutus.Contracts.LendingPool.OnChain.Core.Validator Plutus.Contracts.LendingPool.OnChain.Core.Logic Plutus.Contracts.LendingPool.OnChain.AToken Plutus.Contracts.LendingPool.OffChain.AToken Plutus.Contracts.LendingPool.OffChain.Info Plutus.Contracts.LendingPool.OffChain.Owner Plutus.Contracts.LendingPool.OffChain.State Plutus.Contracts.LendingPool.OffChain.User Plutus.PAB.Simulation Ext.Plutus.Ledger.Value Ext.Plutus.Ledger.Contexts build-depends: base >= 4.9 && < 5, aeson, diff --git a/MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Value.hs b/MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Value.hs new file mode 100644 index 000000000..591245d65 --- /dev/null +++ b/MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Value.hs @@ -0,0 +1,10 @@ +module Ext.Plutus.Ledger.Value where + +import qualified Data.Map as Map +import Ledger (TxOut (txOutValue), + TxOutTx (txOutTxOut), Value) +import Ledger.AddressMap (UtxoMap) +import Plutus.V1.Ledger.Value (Value) + +utxoValue :: UtxoMap -> Value +utxoValue = foldMap (txOutValue . txOutTxOut . snd) . Map.toList diff --git a/MetaLamp/lending-pool/src/Plutus/Abstract/ContractResponse.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/ContractResponse.hs new file mode 100644 index 000000000..94fb78572 --- /dev/null +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/ContractResponse.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Plutus.Abstract.ContractResponse where + +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 (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import qualified Data.Text as Text +import Data.Void (Void) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Scripts as Scripts +import qualified Ledger.Typed.Scripts as Scripts +import Playground.Contract +import Plutus.Abstract.OutputValue (OutputValue (..)) +import qualified Plutus.Abstract.TxUtils as TxUtils +import Plutus.Contract hiding (when) +import Plutus.Contracts.Currency as Currency +import Plutus.Contracts.LendingPool.OnChain.Core (Aave, + AaveDatum (..), + AaveRedeemer (..), + Reserve (..), + UserConfig (..)) +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core +import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken +import Plutus.V1.Ledger.Ada (adaValueOf, + lovelaceValueOf) +import qualified Plutus.V1.Ledger.Address as Addr +import Plutus.V1.Ledger.Value as Value +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding (Monoid (..), + Semigroup (..), + mconcat, unless) +import Prelude (Monoid (..), + Semigroup (..), + show, subtract) +import qualified Prelude +import Text.Printf (printf) + +data ContractResponse e a = ContractSuccess a | ContractError e | ContractPending + deriving stock (Prelude.Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +instance Semigroup (ContractResponse e a) where + a <> b = b + +instance Monoid (ContractResponse e a) where + mempty = ContractPending + mappend = (<>) + +withContractResponse :: forall l a p r s. + HasEndpoint l p s + => Proxy l + -> (a -> r) + -> (p -> Contract (ContractResponse Text r) s Text a) + -> Contract (ContractResponse Text r) s Void () +withContractResponse _ g c = do + e <- runError $ do + p <- endpoint @l + _ <- tell ContractPending + errorHandler `handleError` c p + tell $ 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 diff --git a/MetaLamp/lending-pool/src/Plutus/OutputValue.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/OutputValue.hs similarity index 92% rename from MetaLamp/lending-pool/src/Plutus/OutputValue.hs rename to MetaLamp/lending-pool/src/Plutus/Abstract/OutputValue.hs index c95a9ffa8..96fafabac 100644 --- a/MetaLamp/lending-pool/src/Plutus/OutputValue.hs +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/OutputValue.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TemplateHaskell #-} -module Plutus.OutputValue where +module Plutus.Abstract.OutputValue where import Control.Lens (makeClassy_) import Ledger (TxOutRef, TxOutTx) diff --git a/MetaLamp/lending-pool/src/Plutus/Abstract/State.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/State.hs new file mode 100644 index 000000000..0d18d0c37 --- /dev/null +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/State.hs @@ -0,0 +1,6 @@ +module Plutus.Abstract.State (module Export) + +where + +import Plutus.Abstract.State.Select as Export +import Plutus.Abstract.State.Update as Export diff --git a/MetaLamp/lending-pool/src/Plutus/State/Select.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/State/Select.hs similarity index 96% rename from MetaLamp/lending-pool/src/Plutus/State/Select.hs rename to MetaLamp/lending-pool/src/Plutus/Abstract/State/Select.hs index 784bbdf4d..eabb0146a 100644 --- a/MetaLamp/lending-pool/src/Plutus/State/Select.hs +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/State/Select.hs @@ -7,7 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Plutus.State.Select where +module Plutus.Abstract.State.Select where import Control.Monad hiding (fmap) import qualified Data.ByteString as BS @@ -22,8 +22,8 @@ import Ledger.Constraints.TxConstraints as Constraints import qualified Ledger.Scripts as Scripts import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract +import Plutus.Abstract.OutputValue (OutputValue (..)) import Plutus.Contract hiding (when) -import Plutus.OutputValue (OutputValue (..)) import Plutus.V1.Ledger.Value import qualified PlutusTx import PlutusTx.Prelude hiding (Semigroup (..), diff --git a/MetaLamp/lending-pool/src/Plutus/State/Update.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/State/Update.hs similarity index 97% rename from MetaLamp/lending-pool/src/Plutus/State/Update.hs rename to MetaLamp/lending-pool/src/Plutus/Abstract/State/Update.hs index 4c03e1ac5..b25c0d736 100644 --- a/MetaLamp/lending-pool/src/Plutus/State/Update.hs +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/State/Update.hs @@ -14,7 +14,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -module Plutus.State.Update where +module Plutus.Abstract.State.Update where import Control.Monad hiding (fmap) import qualified Data.ByteString as BS @@ -31,9 +31,9 @@ import qualified Ledger.Scripts as UntypedScripts import Ledger.Typed.Scripts (DatumType, RedeemerType) import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract +import Plutus.Abstract.OutputValue (OutputValue (..)) +import qualified Plutus.Abstract.TxUtils as TxUtils import Plutus.Contract hiding (when) -import qualified Plutus.Contracts.TxUtils as TxUtils -import Plutus.OutputValue (OutputValue (..)) import Plutus.V1.Ledger.Value import PlutusTx (IsData) import qualified PlutusTx diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/TxUtils.hs b/MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs similarity index 56% rename from MetaLamp/lending-pool/src/Plutus/Contracts/TxUtils.hs rename to MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs index e492a0311..a542e5dbd 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/TxUtils.hs +++ b/MetaLamp/lending-pool/src/Plutus/Abstract/TxUtils.hs @@ -7,34 +7,37 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Plutus.Contracts.TxUtils where +module Plutus.Abstract.TxUtils where -import Control.Lens (review) -import Control.Monad (void) -import Data.ByteString (ByteString) -import qualified Data.Map as Map -import Data.Text (Text) -import Data.Void (Void) -import Ledger hiding (singleton) -import qualified Ledger.Constraints as Constraints -import qualified Ledger.Constraints.OnChain as Constraints -import qualified Ledger.Constraints.TxConstraints as Constraints -import Ledger.Typed.Scripts (DatumType, MonetaryPolicy, - RedeemerType, TypedValidator) -import qualified Ledger.Typed.Scripts as Scripts +import Control.Lens (review) +import Control.Monad (void) +import Data.ByteString (ByteString) +import qualified Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +import Ledger hiding (singleton) +import qualified Ledger.Constraints as Constraints +import qualified Ledger.Constraints.OnChain as Constraints +import qualified Ledger.Constraints.TxConstraints as Constraints +import Ledger.Typed.Scripts (DatumType, + MonetaryPolicy, + RedeemerType, + TypedValidator) +import qualified Ledger.Typed.Scripts as Scripts +import Plutus.Abstract.OutputValue (OutputValue (..)) import Plutus.Contract -import qualified Plutus.Contracts.FungibleToken as FungibleToken -import Plutus.OutputValue (OutputValue (..)) -import Plutus.V1.Ledger.Contexts (ScriptContext, - scriptCurrencySymbol) -import qualified Plutus.V1.Ledger.Scripts as Scripts -import Plutus.V1.Ledger.Value (AssetClass (unAssetClass), - TokenName (..), assetClass, - assetClassValue, - assetClassValueOf) +import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken +import Plutus.V1.Ledger.Contexts (ScriptContext, + scriptCurrencySymbol) +import qualified Plutus.V1.Ledger.Scripts as Scripts +import Plutus.V1.Ledger.Value (AssetClass (unAssetClass), + TokenName (..), + assetClass, + assetClassValue, + assetClassValueOf) import qualified PlutusTx -import PlutusTx.Prelude hiding (Semigroup (..)) -import Prelude (Semigroup (..)) +import PlutusTx.Prelude hiding (Semigroup (..)) +import Prelude (Semigroup (..)) import qualified Prelude type TxPair a = (Constraints.ScriptLookups a, Constraints.TxConstraints (RedeemerType a) (DatumType a)) diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/AToken.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/AToken.hs deleted file mode 100644 index 583e14108..000000000 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/AToken.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Plutus.Contracts.AToken where - -import Control.Monad (void) -import Data.ByteString (ByteString) -import qualified Data.Map as Map -import Data.Text (Text) -import Data.Void (Void) -import Ext.Plutus.Ledger.Contexts (scriptInputsAt) -import Ledger hiding (singleton) -import Ledger.Constraints as Constraints -import Ledger.Constraints.OnChain as Constraints -import Ledger.Constraints.TxConstraints as Constraints -import Ledger.Typed.Scripts (MonetaryPolicy) -import qualified Ledger.Typed.Scripts as Scripts -import Plutus.Contract -import Plutus.Contracts.Core (Aave, AaveScript, - Reserve (..)) -import qualified Plutus.Contracts.Core as Core -import qualified Plutus.Contracts.FungibleToken as FungibleToken -import qualified Plutus.Contracts.State as State -import qualified Plutus.Contracts.TxUtils as TxUtils -import Plutus.OutputValue (OutputValue (..)) -import Plutus.V1.Ledger.Contexts (ScriptContext, - scriptCurrencySymbol) -import qualified Plutus.V1.Ledger.Scripts as Scripts -import Plutus.V1.Ledger.Value (AssetClass (..), - TokenName (..), assetClass, - assetClassValue, - assetClassValueOf) -import qualified PlutusTx -import PlutusTx.Prelude hiding (Semigroup (..)) -import qualified PlutusTx.Semigroup as Semigroup -import Prelude (Semigroup (..)) -import qualified Prelude - -{-# INLINABLE validator #-} -validator :: ValidatorHash -> AssetClass -> TokenName -> ScriptContext -> Bool -validator aaveScript underlyingAsset aTokenName ctx = - traceIfFalse "Aave tokens mint forbidden" $ amountMinted /= 0 && amountScriptAsset == amountMinted - where - txInfo :: TxInfo - txInfo = scriptContextTxInfo ctx - aTokenCurrency :: AssetClass - aTokenCurrency = assetClass (ownCurrencySymbol ctx) aTokenName - amountAsset :: Value -> Integer - amountAsset = flip assetClassValueOf underlyingAsset - - amountMinted :: Integer - amountMinted = assetClassValueOf (txInfoForge txInfo) aTokenCurrency - - amountScriptAsset :: Integer - amountScriptAsset = - let outputValue = foldMap snd $ scriptOutputsAt aaveScript txInfo - inputValue = foldMap snd $ scriptInputsAt aaveScript txInfo - in amountAsset outputValue - amountAsset inputValue - -makeLiquidityPolicy :: ValidatorHash -> AssetClass -> MonetaryPolicy -makeLiquidityPolicy aaveScript asset = Scripts.mkMonetaryPolicyScript $ - $$(PlutusTx.compile [|| \s a t -> Scripts.wrapMonetaryPolicy $ validator s a t||]) - `PlutusTx.applyCode` - PlutusTx.liftCode aaveScript - `PlutusTx.applyCode` - PlutusTx.liftCode asset - `PlutusTx.applyCode` - PlutusTx.liftCode aToken - where - aToken = aTokenName asset - -makeAToken :: ValidatorHash -> AssetClass -> AssetClass -makeAToken aaveScript asset = assetClass (scriptCurrencySymbol $ makeLiquidityPolicy aaveScript asset) (aTokenName asset) - -{-# INLINABLE aTokenName #-} -aTokenName :: AssetClass -> TokenName -aTokenName asset = TokenName $ "a" Semigroup.<> case asset of - AssetClass (_,TokenName n) -> n - -forgeATokensFrom :: forall w s. (HasBlockchainActions s) => Aave -> Reserve -> PubKeyHash -> Integer -> Contract w s Text (TxUtils.TxPair AaveScript) -forgeATokensFrom aave reserve pkh amount = do - let policy = makeLiquidityPolicy (Core.aaveHash aave) (rCurrency reserve) - aTokenAmount = amount -- / rLiquidityIndex reserve -- TODO: how should we divide? - forgeValue = assetClassValue (rAToken reserve) aTokenAmount - let payment = assetClassValue (rCurrency reserve) amount - pure $ - TxUtils.mustForgeValue @AaveScript policy forgeValue - <> (Prelude.mempty, mustPayToPubKey pkh forgeValue) - <> TxUtils.mustPayToScript (Core.aaveInstance aave) pkh Core.ReserveFundsDatum payment - -burnATokensFrom :: (HasBlockchainActions s) => Aave -> Reserve -> PubKeyHash -> Integer -> Contract w s Text (TxUtils.TxPair AaveScript) -burnATokensFrom aave reserve pkh amount = do - let asset = rCurrency reserve - let userConfigId = (asset, pkh) - utxos <- - Map.filter ((> 0) . flip assetClassValueOf asset . txOutValue . txOutTxOut) - <$> utxoAt (Core.aaveAddress aave) - let balance = mconcat . fmap (txOutValue . txOutTxOut) . map snd . Map.toList $ utxos - aTokenAmount = amount - remainder = assetClassValueOf balance asset - aTokenAmount - policy = makeLiquidityPolicy (Core.aaveHash aave) asset - burnValue = negate $ assetClassValue (rAToken reserve) aTokenAmount - spendInputs = (\(ref, tx) -> OutputValue ref tx (Core.WithdrawRedeemer userConfigId)) <$> Map.toList utxos - pure $ - TxUtils.mustForgeValue policy burnValue - <> TxUtils.mustSpendFromScript (Core.aaveInstance aave) spendInputs pkh (assetClassValue asset aTokenAmount) - <> TxUtils.mustPayToScript (Core.aaveInstance aave) pkh Core.ReserveFundsDatum (assetClassValue asset remainder) diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs new file mode 100644 index 000000000..4fb7f21ae --- /dev/null +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/AToken.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Plutus.Contracts.LendingPool.OffChain.AToken where + +import Control.Monad (void) +import Data.ByteString (ByteString) +import qualified Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +import Ext.Plutus.Ledger.Contexts (scriptInputsAt) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import Ledger.Typed.Scripts (MonetaryPolicy) +import qualified Ledger.Typed.Scripts as Scripts +import Plutus.Abstract.OutputValue (OutputValue (..)) +import qualified Plutus.Abstract.TxUtils as TxUtils +import Plutus.Contract +import Plutus.Contracts.LendingPool.OnChain.AToken (makeLiquidityPolicy) +import Plutus.Contracts.LendingPool.OnChain.Core (Aave, AaveScript, + Reserve (..)) +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core +import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken +import Plutus.V1.Ledger.Contexts (ScriptContext, + scriptCurrencySymbol) +import qualified Plutus.V1.Ledger.Scripts as Scripts +import Plutus.V1.Ledger.Value (AssetClass (..), + TokenName (..), + assetClass, + assetClassValue, + assetClassValueOf) +import qualified PlutusTx +import PlutusTx.Prelude hiding + (Semigroup (..)) +import qualified PlutusTx.Semigroup as Semigroup +import Prelude (Semigroup (..)) +import qualified Prelude + +forgeATokensFrom :: forall w s. (HasBlockchainActions s) => Aave -> Reserve -> PubKeyHash -> Integer -> Contract w s Text (TxUtils.TxPair AaveScript) +forgeATokensFrom aave reserve pkh amount = do + let policy = makeLiquidityPolicy (Core.aaveHash aave) (rCurrency reserve) + aTokenAmount = amount -- / rLiquidityIndex reserve -- TODO: how should we divide? + forgeValue = assetClassValue (rAToken reserve) aTokenAmount + let payment = assetClassValue (rCurrency reserve) amount + pure $ + TxUtils.mustForgeValue @AaveScript policy forgeValue + <> (Prelude.mempty, mustPayToPubKey pkh forgeValue) + <> TxUtils.mustPayToScript (Core.aaveInstance aave) pkh Core.ReserveFundsDatum payment + +burnATokensFrom :: (HasBlockchainActions s) => Aave -> Reserve -> PubKeyHash -> Integer -> Contract w s Text (TxUtils.TxPair AaveScript) +burnATokensFrom aave reserve pkh amount = do + let asset = rCurrency reserve + let userConfigId = (asset, pkh) + utxos <- + Map.filter ((> 0) . flip assetClassValueOf asset . txOutValue . txOutTxOut) + <$> utxoAt (Core.aaveAddress aave) + let balance = mconcat . fmap (txOutValue . txOutTxOut) . map snd . Map.toList $ utxos + aTokenAmount = amount + remainder = assetClassValueOf balance asset - aTokenAmount + policy = makeLiquidityPolicy (Core.aaveHash aave) asset + burnValue = negate $ assetClassValue (rAToken reserve) aTokenAmount + spendInputs = (\(ref, tx) -> OutputValue ref tx (Core.WithdrawRedeemer userConfigId)) <$> Map.toList utxos + pure $ + TxUtils.mustForgeValue policy burnValue + <> TxUtils.mustSpendFromScript (Core.aaveInstance aave) spendInputs pkh (assetClassValue asset aTokenAmount) + <> TxUtils.mustPayToScript (Core.aaveInstance aave) pkh Core.ReserveFundsDatum (assetClassValue asset remainder) diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs new file mode 100644 index 000000000..54d3b6959 --- /dev/null +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Info.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Plutus.Contracts.LendingPool.OffChain.Info where + +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 (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import qualified Data.Text as Text +import Data.Void (Void) +import Ext.Plutus.Ledger.Value (utxoValue) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Scripts as Scripts +import qualified Ledger.Typed.Scripts as Scripts +import Playground.Contract +import Plutus.Abstract.ContractResponse (ContractResponse, + withContractResponse) +import Plutus.Abstract.OutputValue (OutputValue (..)) +import qualified Plutus.Abstract.TxUtils as TxUtils +import Plutus.Contract hiding (when) +import Plutus.Contracts.Currency as Currency +import qualified Plutus.Contracts.LendingPool.OffChain.AToken as AToken +import qualified Plutus.Contracts.LendingPool.OffChain.State as State +import Plutus.Contracts.LendingPool.OnChain.Core (Aave, + AaveDatum (..), + AaveRedeemer (..), + Reserve (..), + UserConfig (..)) +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core +import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken +import qualified Plutus.Contracts.Service.Oracle as Oracle +import Plutus.V1.Ledger.Ada (adaValueOf, + lovelaceValueOf) +import qualified Plutus.V1.Ledger.Address as Addr +import Plutus.V1.Ledger.Value as Value +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Monoid (..), + Semigroup (..), + mconcat, unless) +import Prelude (Monoid (..), + Semigroup (..), + show, subtract) +import qualified Prelude +import Text.Printf (printf) + +-- | Gets current Lending Pool reserves state +reserves :: HasBlockchainActions s => Aave -> Contract w s Text (AssocMap.Map AssetClass Reserve) +reserves aave = ovValue <$> State.findAaveReserves aave + +-- | Gets current Lending Pool user configs state +users :: HasBlockchainActions s => Aave -> Contract w s Text (AssocMap.Map (AssetClass, PubKeyHash) UserConfig) +users aave = ovValue <$> State.findAaveUserConfigs aave + +fundsAt :: HasBlockchainActions s => PubKeyHash -> Contract w s Text Value +fundsAt pkh = utxoValue <$> utxoAt (pubKeyHashAddress pkh) + +-- | Gets all UTxOs belonging to the Lending Pool script and concats them into one Value +poolFunds :: HasBlockchainActions s => Aave -> Contract w s Text Value +poolFunds aave = utxoValue <$> utxoAt (Core.aaveAddress aave) + +type AaveInfoSchema = + BlockchainActions + .\/ Endpoint "fundsAt" PubKeyHash + .\/ Endpoint "poolFunds" () + .\/ Endpoint "reserves" () + .\/ Endpoint "users" () + +data InfoContractState = + FundsAt Value + | PoolFunds Value + | Reserves (AssocMap.Map AssetClass Reserve) + | Users (AssocMap.Map (AssetClass, PubKeyHash) UserConfig) + deriving (Prelude.Eq, Show, Generic, FromJSON, ToJSON) + +infoEndpoints :: Aave -> Contract (ContractResponse Text InfoContractState) AaveInfoSchema Void () +infoEndpoints aave = forever $ + withContractResponse (Proxy @"fundsAt") FundsAt fundsAt + `select` withContractResponse (Proxy @"poolFunds") PoolFunds (const $ poolFunds aave) + `select` withContractResponse (Proxy @"reserves") Reserves (const $ reserves aave) + `select` withContractResponse (Proxy @"users") Users (const $ users aave) diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs new file mode 100644 index 000000000..ca2cb309f --- /dev/null +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Plutus.Contracts.LendingPool.OffChain.Owner where + +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 (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import qualified Data.Text as Text +import Data.Void (Void) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Scripts as Scripts +import qualified Ledger.Typed.Scripts as Scripts +import Playground.Contract +import Plutus.Abstract.ContractResponse (ContractResponse, + withContractResponse) +import Plutus.Abstract.OutputValue (OutputValue (..)) +import qualified Plutus.Abstract.TxUtils as TxUtils +import Plutus.Contract hiding (when) +import Plutus.Contracts.Currency as Currency +import qualified Plutus.Contracts.LendingPool.OffChain.State as State +import qualified Plutus.Contracts.LendingPool.OnChain.AToken as AToken +import Plutus.Contracts.LendingPool.OnChain.Core (Aave, + AaveDatum (..), + AaveRedeemer (..), + Reserve (..), + UserConfig (..)) +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core +import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken +import qualified Plutus.Contracts.Service.Oracle as Oracle +import Plutus.V1.Ledger.Ada (adaValueOf, + lovelaceValueOf) +import qualified Plutus.V1.Ledger.Address as Addr +import Plutus.V1.Ledger.Value as Value +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Monoid (..), + Semigroup (..), + mconcat, unless) +import Prelude (Monoid (..), + Semigroup (..), + show, subtract) +import qualified Prelude +import Text.Printf (printf) + +data CreateParams = + CreateParams + { cpAsset :: AssetClass, + cpOracle :: Oracle.Oracle + } + deriving stock (Prelude.Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON, ToSchema) + +PlutusTx.makeLift ''CreateParams + +createReserve :: Aave -> CreateParams -> Reserve +createReserve aave CreateParams {..} = + Reserve + { rCurrency = cpAsset, + rAmount = 0, + rAToken = AToken.makeAToken (Core.aaveHash aave) cpAsset, + rLiquidityIndex = 1, + rCurrentStableBorrowRate = 11 % 10, -- TODO configure borrow rate when lending core will be ready + rTrustedOracle = Oracle.toTuple cpOracle + } + +-- | 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 = start' $ do + pkh <- pubKeyHash <$> ownPubKey + 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 + -- TODO how to ensure that newly minted owner token is paid to the script before someone else spends it? + ledgerTx <- TxUtils.submitTxPair aaveTokenTx + void $ awaitTxConfirmed $ txId ledgerTx + + let reserveMap = AssocMap.fromList $ fmap (\params -> (cpAsset params, createReserve aave params)) params + reservesTx <- State.putReserves aave Core.StartRedeemer reserveMap + ledgerTx <- TxUtils.submitTxPair reservesTx + void $ awaitTxConfirmed $ txId ledgerTx + userConfigsTx <- State.putUserConfigs aave Core.StartRedeemer AssocMap.empty + ledgerTx <- TxUtils.submitTxPair userConfigsTx + void $ awaitTxConfirmed $ txId ledgerTx + + logInfo @Prelude.String $ printf "started Aave %s at address %s" (show aave) (show $ Core.aaveAddress aave) + pure aave + +type AaveOwnerSchema = + BlockchainActions + .\/ Endpoint "start" [CreateParams] + +data OwnerContractState = Started Aave + deriving (Prelude.Eq, Show, Generic, FromJSON, ToJSON) + +ownerEndpoints :: Contract (ContractResponse Text OwnerContractState) AaveOwnerSchema Void () +ownerEndpoints = forever $ withContractResponse (Proxy @"start") Started start diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/State.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/State.hs similarity index 65% rename from MetaLamp/lending-pool/src/Plutus/Contracts/State.hs rename to MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/State.hs index 8fefc843a..4a4211b5e 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/State.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/State.hs @@ -8,59 +8,64 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -module Plutus.Contracts.State where +module Plutus.Contracts.LendingPool.OffChain.State where import Control.Lens -import Control.Monad hiding (fmap) -import qualified Data.ByteString as BS -import qualified Data.Map as Map -import Data.Monoid (Last (..)) -import Data.Proxy (Proxy (..)) -import Data.Text (Text, pack) -import qualified Data.Text as Text -import Data.Void (Void) -import Ledger hiding (singleton) -import Ledger.Constraints as Constraints -import Ledger.Constraints.OnChain as Constraints -import Ledger.Constraints.TxConstraints as Constraints -import qualified Ledger.Scripts as Scripts -import qualified Ledger.Typed.Scripts as Scripts +import Control.Monad hiding (fmap) +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import Data.Monoid (Last (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import qualified Data.Text as Text +import Data.Void (Void) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Scripts as Scripts +import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract -import Plutus.Contract hiding (when) -import Plutus.Contracts.Core (Aave (..), AaveDatum (..), - AaveRedeemer (..), - AaveScript, Reserve (..), - UserConfig (..)) -import qualified Plutus.Contracts.Core as Core -import Plutus.Contracts.Currency as Currency -import qualified Plutus.Contracts.FungibleToken as FungibleToken -import qualified Plutus.Contracts.TxUtils as TxUtils -import Plutus.OutputValue (OutputValue (..), _ovValue) -import qualified Plutus.State.Select as Select -import Plutus.State.Update (PutStateHandle (..), - StateHandle (..)) -import qualified Plutus.State.Update as Update -import Plutus.V1.Ledger.Ada (adaValueOf, lovelaceValueOf) -import Plutus.V1.Ledger.Value as Value +import Plutus.Abstract.OutputValue (OutputValue (..), + _ovValue) +import qualified Plutus.Abstract.State as State +import Plutus.Abstract.State.Update (PutStateHandle (..), + StateHandle (..)) +import qualified Plutus.Abstract.TxUtils as TxUtils +import Plutus.Contract hiding (when) +import Plutus.Contracts.Currency as Currency +import Plutus.Contracts.LendingPool.OnChain.Core (Aave (..), + AaveDatum (..), + AaveRedeemer (..), + AaveScript, + Reserve (..), + UserConfig (..)) +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core +import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken +import Plutus.V1.Ledger.Ada (adaValueOf, + lovelaceValueOf) +import Plutus.V1.Ledger.Value as Value import qualified PlutusTx -import qualified PlutusTx.AssocMap as AssocMap -import PlutusTx.Prelude hiding (Functor (..), - Semigroup (..), unless) -import Prelude (Semigroup (..), fmap) +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding (Functor (..), + Semigroup (..), + unless) +import Prelude (Semigroup (..), + fmap) import qualified Prelude findOutputsBy :: HasBlockchainActions s => Aave -> AssetClass -> (AaveDatum -> Maybe a) -> Contract w s Text [OutputValue a] -findOutputsBy aave = Select.findOutputsBy (Core.aaveAddress aave) +findOutputsBy aave = State.findOutputsBy (Core.aaveAddress aave) findOutputBy :: HasBlockchainActions s => Aave -> AssetClass -> (AaveDatum -> Maybe a) -> Contract w s Text (OutputValue a) -findOutputBy aave = Select.findOutputBy (Core.aaveAddress aave) +findOutputBy aave = State.findOutputBy (Core.aaveAddress aave) findAaveOwnerToken :: HasBlockchainActions s => Aave -> Contract w s Text (OutputValue PubKeyHash) findAaveOwnerToken aave@Aave{..} = findOutputBy aave aaveProtocolInst (^? Core._LendingPoolDatum) reserveStateToken, userStateToken :: Aave -> AssetClass -reserveStateToken aave = Update.makeStateToken (Core.aaveHash aave) (aaveProtocolInst aave) "aaveReserve" -userStateToken aave = Update.makeStateToken (Core.aaveHash aave) (aaveProtocolInst aave) "aaveUser" +reserveStateToken aave = State.makeStateToken (Core.aaveHash aave) (aaveProtocolInst aave) "aaveReserve" +userStateToken aave = State.makeStateToken (Core.aaveHash aave) (aaveProtocolInst aave) "aaveUser" findAaveReserves :: HasBlockchainActions s => Aave -> Contract w s Text (OutputValue (AssocMap.Map AssetClass Reserve)) findAaveReserves aave = findOutputBy aave (reserveStateToken aave) (^? Core._ReservesDatum . _2) @@ -81,13 +86,13 @@ findAaveUserConfig aave userConfigId = do putState :: (HasBlockchainActions s) => Aave -> StateHandle AaveScript a -> a -> Contract w s Text (TxUtils.TxPair AaveScript) putState aave stateHandle newState = do ownerTokenOutput <- fmap Core.LendingPoolDatum <$> findAaveOwnerToken aave - Update.putState + State.putState PutStateHandle { script = Core.aaveInstance aave, ownerToken = aaveProtocolInst aave, ownerTokenOutput = ownerTokenOutput } stateHandle newState updateState :: (HasBlockchainActions s) => Aave -> StateHandle AaveScript a -> OutputValue a -> Contract w s Text (TxUtils.TxPair AaveScript, a) -updateState aave = Update.updateState (Core.aaveInstance aave) +updateState aave = State.updateState (Core.aaveInstance aave) makeReserveHandle :: Aave -> (AssocMap.Map AssetClass Reserve -> AaveRedeemer) -> StateHandle AaveScript (AssocMap.Map AssetClass Reserve) makeReserveHandle aave toRedeemer = diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/Endpoints.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs similarity index 63% rename from MetaLamp/lending-pool/src/Plutus/Contracts/Endpoints.hs rename to MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs index 8c3bb8610..b2c97dc9b 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/Endpoints.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/User.hs @@ -16,170 +16,56 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Plutus.Contracts.Endpoints where - -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 (..)) -import Data.Proxy (Proxy (..)) -import Data.Text (Text, pack) -import qualified Data.Text as Text -import Data.Void (Void) -import Ledger hiding (singleton) -import Ledger.Constraints as Constraints -import Ledger.Constraints.OnChain as Constraints -import Ledger.Constraints.TxConstraints as Constraints -import qualified Ledger.Scripts as Scripts -import qualified Ledger.Typed.Scripts as Scripts +module Plutus.Contracts.LendingPool.OffChain.User where + +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 (..)) +import Data.Proxy (Proxy (..)) +import Data.Text (Text, pack) +import qualified Data.Text as Text +import Data.Void (Void) +import Ext.Plutus.Ledger.Value (utxoValue) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Scripts as Scripts +import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract -import Plutus.Contract hiding (when) -import qualified Plutus.Contracts.AToken as AToken -import Plutus.Contracts.Core (Aave, AaveDatum (..), - AaveRedeemer (..), - Reserve (..), - UserConfig (..)) -import qualified Plutus.Contracts.Core as Core -import Plutus.Contracts.Currency as Currency -import qualified Plutus.Contracts.FungibleToken as FungibleToken -import qualified Plutus.Contracts.Oracle as Oracle -import qualified Plutus.Contracts.State as State -import qualified Plutus.Contracts.TxUtils as TxUtils -import Plutus.OutputValue (OutputValue (..)) -import Plutus.V1.Ledger.Ada (adaValueOf, lovelaceValueOf) -import qualified Plutus.V1.Ledger.Address as Addr -import Plutus.V1.Ledger.Value as Value +import Plutus.Abstract.ContractResponse (ContractResponse, + withContractResponse) +import Plutus.Abstract.OutputValue (OutputValue (..)) +import qualified Plutus.Abstract.TxUtils as TxUtils +import Plutus.Contract hiding (when) +import Plutus.Contracts.Currency as Currency +import qualified Plutus.Contracts.LendingPool.OffChain.AToken as AToken +import qualified Plutus.Contracts.LendingPool.OffChain.State as State +import Plutus.Contracts.LendingPool.OnChain.Core (Aave, + AaveDatum (..), + AaveRedeemer (..), + Reserve (..), + UserConfig (..)) +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core +import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken +import qualified Plutus.Contracts.Service.Oracle as Oracle +import Plutus.V1.Ledger.Ada (adaValueOf, + lovelaceValueOf) +import qualified Plutus.V1.Ledger.Address as Addr +import Plutus.V1.Ledger.Value as Value import qualified PlutusTx -import qualified PlutusTx.AssocMap as AssocMap -import PlutusTx.Prelude hiding (Monoid (..), - Semigroup (..), mconcat, - unless) -import Prelude (Monoid (..), Semigroup (..), - show, subtract) +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Monoid (..), + Semigroup (..), + mconcat, unless) +import Prelude (Monoid (..), + Semigroup (..), + show, subtract) import qualified Prelude -import Text.Printf (printf) - -data CreateParams = - CreateParams - { cpAsset :: AssetClass, - cpOracle :: Oracle.Oracle - } - deriving stock (Prelude.Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON, ToSchema) - -PlutusTx.makeLift ''CreateParams - -createReserve :: Aave -> CreateParams -> Reserve -createReserve aave CreateParams {..} = - Reserve - { rCurrency = cpAsset, - rAmount = 0, - rAToken = AToken.makeAToken (Core.aaveHash aave) cpAsset, - rLiquidityIndex = 1, - rCurrentStableBorrowRate = 11 % 10, -- TODO configure borrow rate when lending core will be ready - rTrustedOracle = Oracle.toTuple cpOracle - } - --- | 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 = start' $ do - pkh <- pubKeyHash <$> ownPubKey - 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 - -- TODO how to ensure that newly minted owner token is paid to the script before someone else spends it? - ledgerTx <- TxUtils.submitTxPair aaveTokenTx - void $ awaitTxConfirmed $ txId ledgerTx - - let reserveMap = AssocMap.fromList $ fmap (\params -> (cpAsset params, createReserve aave params)) params - reservesTx <- State.putReserves aave Core.StartRedeemer reserveMap - ledgerTx <- TxUtils.submitTxPair reservesTx - void $ awaitTxConfirmed $ txId ledgerTx - userConfigsTx <- State.putUserConfigs aave Core.StartRedeemer AssocMap.empty - ledgerTx <- TxUtils.submitTxPair userConfigsTx - void $ awaitTxConfirmed $ txId ledgerTx - - logInfo @Prelude.String $ printf "started Aave %s at address %s" (show aave) (show $ Core.aaveAddress aave) - pure aave - -data ContractResponse e a = ContractSuccess a | ContractError e | ContractPending - deriving stock (Prelude.Eq, Show, Generic) - deriving anyclass (ToJSON, FromJSON) - -instance Semigroup (ContractResponse e a) where - a <> b = b - -instance Monoid (ContractResponse e a) where - mempty = ContractPending - mappend = (<>) - -handleContract :: forall l a p r s. - HasEndpoint l p s - => Proxy l - -> (a -> r) - -> (p -> Contract (ContractResponse Text r) s Text a) - -> Contract (ContractResponse Text r) s Void () -handleContract _ g c = do - e <- runError $ do - p <- endpoint @l - _ <- tell ContractPending - errorHandler `handleError` c p - tell $ 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 AaveOwnerSchema = - BlockchainActions - .\/ Endpoint "start" [CreateParams] - -data OwnerContractState = Started Aave - deriving (Prelude.Eq, Show, Generic, FromJSON, ToJSON) - -ownerEndpoints :: Contract (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) -reserves aave = ovValue <$> State.findAaveReserves aave - --- | Gets current Lending Pool user configs state -users :: HasBlockchainActions s => Aave -> Contract w s Text (AssocMap.Map (AssetClass, PubKeyHash) UserConfig) -users aave = ovValue <$> State.findAaveUserConfigs aave - -valueAt :: HasBlockchainActions s => Address -> Contract w s Text Value -valueAt address = do - os <- map snd . Map.toList <$> utxoAt address - pure $ mconcat [txOutValue $ txOutTxOut o | o <- os] - -getOwnPubKey :: HasBlockchainActions s => Contract w s Text PubKeyHash -getOwnPubKey = pubKeyHash <$> ownPubKey - --- | Gets all UTxOs belonging to a user and concats them into one Value -fundsAt :: HasBlockchainActions s => PubKeyHash -> Contract w s Text Value -fundsAt pkh = valueAt (pubKeyHashAddress pkh) - -balanceAt :: HasBlockchainActions s => PubKeyHash -> AssetClass -> Contract w s Text Integer -balanceAt pkh asset = flip assetClassValueOf asset <$> fundsAt pkh - --- | Gets all UTxOs belonging to the Lending Pool script and concats them into one Value -poolFunds :: HasBlockchainActions s => Aave -> Contract w s Text Value -poolFunds aave = valueAt (Core.aaveAddress aave) - -ownPubKeyBalance :: HasBlockchainActions s => Contract w s Text Value -ownPubKeyBalance = getOwnPubKey >>= fundsAt +import Text.Printf (printf) data DepositParams = DepositParams { @@ -355,6 +241,13 @@ data ProvideCollateralParams = PlutusTx.unstableMakeIsData ''ProvideCollateralParams PlutusTx.makeLift ''ProvideCollateralParams +-- | Gets all UTxOs belonging to a user and concats them into one Value +fundsAt :: HasBlockchainActions s => PubKeyHash -> Contract w s Text Value +fundsAt pkh = utxoValue <$> utxoAt (pubKeyHashAddress pkh) + +balanceAt :: HasBlockchainActions s => PubKeyHash -> AssetClass -> Contract w s Text Integer +balanceAt pkh asset = flip assetClassValueOf asset <$> fundsAt pkh + -- | User deposits N amount of aToken as collateral, his investment entry state is increased by N provideCollateral :: (HasBlockchainActions s) => Aave -> ProvideCollateralParams -> Contract w s Text () provideCollateral aave ProvideCollateralParams {..} = do @@ -440,6 +333,13 @@ 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) + +getOwnPubKey :: HasBlockchainActions s => Contract w s Text PubKeyHash +getOwnPubKey = pubKeyHash <$> ownPubKey + +ownPubKeyBalance :: HasBlockchainActions s => Contract w s Text Value +ownPubKeyBalance = getOwnPubKey >>= fundsAt + type AaveUserSchema = BlockchainActions .\/ Endpoint "deposit" DepositParams @@ -467,32 +367,11 @@ Lens.makeClassyPrisms ''UserContractState -- TODO ? add repayWithCollateral userEndpoints :: Aave -> Contract (ContractResponse Text UserContractState) AaveUserSchema Void () userEndpoints aave = forever $ - handleContract (Proxy @"deposit") (const Deposited) (deposit aave) - `select` handleContract (Proxy @"withdraw") (const Withdrawn) (withdraw aave) - `select` handleContract (Proxy @"borrow") (const Borrowed) (borrow aave) - `select` handleContract (Proxy @"repay") (const Repaid) (repay aave) - `select` handleContract (Proxy @"provideCollateral") (const CollateralProvided) (provideCollateral aave) - `select` handleContract (Proxy @"revokeCollateral") (const CollateralRevoked) (revokeCollateral aave) - `select` handleContract (Proxy @"ownPubKey") GetPubKey (const getOwnPubKey) - `select` handleContract (Proxy @"ownPubKeyBalance") GetPubKeyBalance (const ownPubKeyBalance) - -type AaveInfoSchema = - BlockchainActions - .\/ Endpoint "fundsAt" PubKeyHash - .\/ Endpoint "poolFunds" () - .\/ Endpoint "reserves" () - .\/ Endpoint "users" () - -data InfoContractState = - FundsAt Value - | PoolFunds Value - | Reserves (AssocMap.Map AssetClass Reserve) - | Users (AssocMap.Map (AssetClass, PubKeyHash) UserConfig) - deriving (Prelude.Eq, Show, Generic, FromJSON, ToJSON) - -infoEndpoints :: Aave -> Contract (ContractResponse Text InfoContractState) AaveInfoSchema Void () -infoEndpoints aave = forever $ - handleContract (Proxy @"fundsAt") FundsAt fundsAt - `select` handleContract (Proxy @"poolFunds") PoolFunds (const $ poolFunds aave) - `select` handleContract (Proxy @"reserves") Reserves (const $ reserves aave) - `select` handleContract (Proxy @"users") Users (const $ users aave) + withContractResponse (Proxy @"deposit") (const Deposited) (deposit aave) + `select` withContractResponse (Proxy @"withdraw") (const Withdrawn) (withdraw aave) + `select` withContractResponse (Proxy @"borrow") (const Borrowed) (borrow aave) + `select` withContractResponse (Proxy @"repay") (const Repaid) (repay aave) + `select` withContractResponse (Proxy @"provideCollateral") (const CollateralProvided) (provideCollateral aave) + `select` withContractResponse (Proxy @"revokeCollateral") (const CollateralRevoked) (revokeCollateral aave) + `select` withContractResponse (Proxy @"ownPubKey") GetPubKey (const getOwnPubKey) + `select` withContractResponse (Proxy @"ownPubKeyBalance") GetPubKeyBalance (const ownPubKeyBalance) diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/AToken.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/AToken.hs new file mode 100644 index 000000000..16f883817 --- /dev/null +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/AToken.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Plutus.Contracts.LendingPool.OnChain.AToken where + +import Control.Monad (void) +import Data.ByteString (ByteString) +import qualified Data.Map as Map +import Data.Text (Text) +import Data.Void (Void) +import Ext.Plutus.Ledger.Contexts (scriptInputsAt) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import Ledger.Typed.Scripts (MonetaryPolicy) +import qualified Ledger.Typed.Scripts as Scripts +import Plutus.Abstract.OutputValue (OutputValue (..)) +import qualified Plutus.Abstract.TxUtils as TxUtils +import Plutus.Contract +import Plutus.Contracts.LendingPool.OnChain.Core (Aave, AaveScript, + Reserve (..)) +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core +import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken +import Plutus.V1.Ledger.Contexts (ScriptContext, + scriptCurrencySymbol) +import qualified Plutus.V1.Ledger.Scripts as Scripts +import Plutus.V1.Ledger.Value (AssetClass (..), + TokenName (..), + assetClass, + assetClassValue, + assetClassValueOf) +import qualified PlutusTx +import PlutusTx.Prelude hiding + (Semigroup (..)) +import qualified PlutusTx.Semigroup as Semigroup +import Prelude (Semigroup (..)) +import qualified Prelude + +{-# INLINABLE validator #-} +validator :: ValidatorHash -> AssetClass -> TokenName -> ScriptContext -> Bool +validator aaveScript underlyingAsset aTokenName ctx = + traceIfFalse "Aave tokens mint forbidden" $ amountMinted /= 0 && amountScriptAsset == amountMinted + where + txInfo :: TxInfo + txInfo = scriptContextTxInfo ctx + aTokenCurrency :: AssetClass + aTokenCurrency = assetClass (ownCurrencySymbol ctx) aTokenName + amountAsset :: Value -> Integer + amountAsset = flip assetClassValueOf underlyingAsset + + amountMinted :: Integer + amountMinted = assetClassValueOf (txInfoForge txInfo) aTokenCurrency + + amountScriptAsset :: Integer + amountScriptAsset = + let outputValue = foldMap snd $ scriptOutputsAt aaveScript txInfo + inputValue = foldMap snd $ scriptInputsAt aaveScript txInfo + in amountAsset outputValue - amountAsset inputValue + +makeLiquidityPolicy :: ValidatorHash -> AssetClass -> MonetaryPolicy +makeLiquidityPolicy aaveScript asset = Scripts.mkMonetaryPolicyScript $ + $$(PlutusTx.compile [|| \s a t -> Scripts.wrapMonetaryPolicy $ validator s a t||]) + `PlutusTx.applyCode` + PlutusTx.liftCode aaveScript + `PlutusTx.applyCode` + PlutusTx.liftCode asset + `PlutusTx.applyCode` + PlutusTx.liftCode aToken + where + aToken = aTokenName asset + +makeAToken :: ValidatorHash -> AssetClass -> AssetClass +makeAToken aaveScript asset = assetClass (scriptCurrencySymbol $ makeLiquidityPolicy aaveScript asset) (aTokenName asset) + +{-# INLINABLE aTokenName #-} +aTokenName :: AssetClass -> TokenName +aTokenName asset = TokenName $ "a" Semigroup.<> case asset of + AssetClass (_,TokenName n) -> n diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core.hs new file mode 100644 index 000000000..afd3312c1 --- /dev/null +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fobject-code #-} + +module Plutus.Contracts.LendingPool.OnChain.Core (module Plutus.Contracts.LendingPool.OnChain.Core, module Export, Aave(..), aaveInstance) where + +import Control.Lens ((^?)) +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.Text (Text, + pack) +import Data.Void (Void) +import Ext.Plutus.Ledger.Contexts (findOnlyOneDatumHashByValue, + findValueByDatumHash, + parseDatum, + scriptInputsAt, + valueSpentFrom) +import Ledger hiding + (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Scripts as UntypedScripts +import qualified Ledger.Typed.Scripts as Scripts +import Playground.Contract +import Plutus.Contract hiding + (when) +import Plutus.Contracts.LendingPool.OnChain.Core.Script (AaveDatum, + AaveRedeemer, + AaveScript) +import Plutus.Contracts.LendingPool.OnChain.Core.Script as Export +import Plutus.Contracts.LendingPool.OnChain.Core.Validator (Aave (..), + aaveInstance) +import qualified Plutus.Contracts.Service.Oracle as Oracle +import Plutus.V1.Ledger.Value +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..), + unless) +import Prelude (Semigroup (..)) +import qualified Prelude + +aaveProtocolName :: TokenName +aaveProtocolName = "Aave" + +aaveValidator :: Aave -> Validator +aaveValidator = Scripts.validatorScript . aaveInstance + +aaveHash :: Aave -> Ledger.ValidatorHash +aaveHash = UntypedScripts.validatorHash . aaveValidator + +aaveAddress :: Aave -> Ledger.Address +aaveAddress = Ledger.scriptAddress . aaveValidator + +aave :: CurrencySymbol -> Aave +aave protocol = Aave (assetClass protocol aaveProtocolName) diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Logic.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Logic.hs new file mode 100644 index 000000000..9271b5a04 --- /dev/null +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Logic.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fobject-code #-} + +module Plutus.Contracts.LendingPool.OnChain.Core.Logic where + +import Control.Lens ((^?)) +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.Text (Text, pack) +import Data.Void (Void) +import Ext.Plutus.Ledger.Contexts (findOnlyOneDatumHashByValue, + findValueByDatumHash, + parseDatum, + scriptInputsAt, + valueSpentFrom) +import Ledger hiding + (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Scripts as UntypedScripts +import qualified Ledger.Typed.Scripts as Scripts +import Playground.Contract +import Plutus.Contract hiding (when) +import Plutus.Contracts.LendingPool.OnChain.Core.Script (AaveDatum (..), + AaveRedeemer (..), + Reserve (..), + UserConfig (..)) +import qualified Plutus.Contracts.Service.Oracle as Oracle +import Plutus.V1.Ledger.Value +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..), + unless) +import Prelude (Semigroup (..)) +import qualified Prelude + +{-# INLINABLE pickUserConfigs #-} +pickUserConfigs :: AaveDatum -> Maybe (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig) +pickUserConfigs (UserConfigsDatum stateToken configs) = Just (stateToken, configs) +pickUserConfigs _ = Nothing + +{-# INLINABLE pickReserves #-} +pickReserves :: AaveDatum -> Maybe (AssetClass, AssocMap.Map AssetClass Reserve) +pickReserves (ReservesDatum stateToken configs) = Just (stateToken, configs) +pickReserves _ = Nothing + +{-# INLINABLE pickUserCollateralFunds #-} +pickUserCollateralFunds :: AaveDatum -> Maybe (PubKeyHash, AssetClass) +pickUserCollateralFunds (UserCollateralFundsDatum user aTokenAsset) = Just (user, aTokenAsset) +pickUserCollateralFunds _ = Nothing + +{-# INLINABLE totalDebtAndCollateralInLovelace #-} +totalDebtAndCollateralInLovelace :: + PubKeyHash + -> AssocMap.Map AssetClass Integer + -> AssocMap.Map (AssetClass, PubKeyHash) UserConfig + -> Maybe UserConfig +totalDebtAndCollateralInLovelace actor oracles userConfigs = + foldrM addCollateral (UserConfig 0 0) $ AssocMap.toList userConfigs + where + addCollateral :: + ((AssetClass, PubKeyHash), UserConfig) + -> UserConfig + -> Maybe UserConfig + addCollateral ((asset, user), userConfig) currentTotal + | user == actor = + (\rate -> UserConfig { + ucCollateralizedInvestment = rate * ucCollateralizedInvestment userConfig + ucCollateralizedInvestment currentTotal, + ucDebt = rate * ucDebt userConfig + ucDebt currentTotal } + ) <$> + AssocMap.lookup asset oracles + | otherwise = Just currentTotal + +{-# INLINABLE doesCollateralCoverDebt #-} +doesCollateralCoverDebt :: + PubKeyHash + -> AssocMap.Map AssetClass Integer + -> AssocMap.Map (AssetClass, PubKeyHash) UserConfig + -> Bool +doesCollateralCoverDebt actor oracles userConfigs = maybe False (\UserConfig{..} -> ucDebt <= ucCollateralizedInvestment) $ + totalDebtAndCollateralInLovelace actor oracles userConfigs + +{-# INLINABLE areOraclesTrusted #-} +areOraclesTrusted :: [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] + -> AssocMap.Map AssetClass Reserve + -> Bool +areOraclesTrusted oracles reserves = all checkOracle oracles + where + checkOracle o = let oracle = Oracle.fromTuple o in + Just oracle == (Oracle.fromTuple . rTrustedOracle <$> AssocMap.lookup (Oracle.oAsset oracle) reserves) + +{-# INLINABLE checkNegativeFundsTransformation #-} +checkNegativeFundsTransformation :: ScriptContext -> AssetClass -> PubKeyHash -> Bool +checkNegativeFundsTransformation ctx asset actor = isValidFundsChange + where + txInfo = scriptContextTxInfo ctx + (scriptsHash, scriptsDatumHash) = ownHashes ctx + scriptOutputs = scriptOutputsAt scriptsHash txInfo + + scriptSpentValue = findValueByDatumHash scriptsDatumHash $ scriptInputsAt scriptsHash txInfo + scriptRemainderValue = findValueByDatumHash scriptsDatumHash scriptOutputs + actorSpentValue = valueSpentFrom txInfo actor + actorRemainderValue = valuePaidTo txInfo actor + + isValidFundsChange :: Bool + isValidFundsChange = + let paidAmout = assetClassValueOf actorRemainderValue asset - assetClassValueOf actorSpentValue asset + fundsChange = assetClassValueOf scriptSpentValue asset - assetClassValueOf scriptRemainderValue asset + in fundsChange == paidAmout && fundsChange > 0 && paidAmout > 0 + +{-# INLINABLE checkNegativeReservesTransformation #-} +checkNegativeReservesTransformation :: AssetClass + -> AssocMap.Map AssetClass Reserve + -> ScriptContext + -> (AssetClass, PubKeyHash) + -> Bool +checkNegativeReservesTransformation stateToken reserves ctx (reserveId, _) = + maybe False checkreserves reservesOutputDatum + where + txInfo = scriptContextTxInfo ctx + (scriptsHash, scriptsDatumHash) = ownHashes ctx + scriptOutputs = scriptOutputsAt scriptsHash txInfo + + reservesOutputDatumHash = + findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs + reservesOutputDatum :: + Maybe (AssetClass, AssocMap.Map AssetClass Reserve) + reservesOutputDatum = + reservesOutputDatumHash >>= parseDatum txInfo >>= pickReserves + + remainderDatumHash = findDatumHash (Datum $ PlutusTx.toData ReserveFundsDatum) txInfo + remainderValue = (`findValueByDatumHash` scriptOutputs) <$> remainderDatumHash + + checkreserves :: (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool + checkreserves (newStateToken, newReserves) = + newStateToken == stateToken && + maybe + False + checkReserveState + ((,,) <$> remainderValue <*> AssocMap.lookup reserveId reserves <*> AssocMap.lookup reserveId newReserves) + checkReserveState :: (Value, Reserve, Reserve) -> Bool + checkReserveState (value, oldState, newState) = + let fundsAmount = rAmount newState + in assetClassValueOf value reserveId == fundsAmount && fundsAmount >= 0 && checkReservesConsistency oldState newState + +{-# INLINABLE checkPositiveReservesTransformation #-} +checkPositiveReservesTransformation :: AssetClass + -> AssocMap.Map AssetClass Reserve + -> ScriptContext + -> (AssetClass, PubKeyHash) + -> Bool +checkPositiveReservesTransformation stateToken reserves ctx (reserveId, _) = maybe False checkreserves reservesOutputDatum + where + txInfo = scriptContextTxInfo ctx + (scriptsHash, scriptsDatumHash) = ownHashes ctx + scriptOutputs = scriptOutputsAt scriptsHash txInfo + + reservesOutputDatumHash = + findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs + reservesOutputDatum :: + Maybe (AssetClass, AssocMap.Map AssetClass Reserve) + reservesOutputDatum = + reservesOutputDatumHash >>= parseDatum txInfo >>= pickReserves + + investmentDatumHash = findDatumHash (Datum $ PlutusTx.toData ReserveFundsDatum) txInfo + investmentValue = (`findValueByDatumHash` scriptOutputs) <$> investmentDatumHash + + checkreserves :: (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool + checkreserves (newStateToken, newReserves) = + newStateToken == stateToken && + maybe + False + checkReserveState + ((,,) <$> investmentValue <*> AssocMap.lookup reserveId reserves <*> AssocMap.lookup reserveId newReserves) + checkReserveState :: (Value, Reserve, Reserve) -> Bool + checkReserveState (value, oldState, newState) = + let fundsChange = rAmount newState - rAmount oldState + in assetClassValueOf value reserveId == fundsChange && fundsChange > 0 && checkReservesConsistency oldState newState + +{-# INLINABLE checkReservesConsistency #-} +checkReservesConsistency :: Reserve -> Reserve -> Bool +checkReservesConsistency oldState newState = + rCurrency oldState == rCurrency newState && + rAToken oldState == rAToken newState && + rLiquidityIndex oldState == rLiquidityIndex newState && + rCurrentStableBorrowRate oldState == rCurrentStableBorrowRate newState && + Oracle.fromTuple (rTrustedOracle oldState) == Oracle.fromTuple (rTrustedOracle newState) diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Script.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Script.hs new file mode 100644 index 000000000..f5e1b86b1 --- /dev/null +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Script.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fobject-code #-} + +module Plutus.Contracts.LendingPool.OnChain.Core.Script where + +import Control.Lens ((^?)) +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.Text (Text, pack) +import Data.Void (Void) +import Ext.Plutus.Ledger.Contexts (findOnlyOneDatumHashByValue, + findValueByDatumHash, + parseDatum, scriptInputsAt, + valueSpentFrom) +import Ledger hiding (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Scripts as UntypedScripts +import qualified Ledger.Typed.Scripts as Scripts +import Playground.Contract +import Plutus.Contract hiding (when) +import qualified Plutus.Contracts.Service.Oracle as Oracle +import Plutus.V1.Ledger.Value +import qualified PlutusTx +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding (Semigroup (..), + unless) +import Prelude (Semigroup (..)) +import qualified Prelude + +deriving anyclass instance ToSchema Rational + +data Reserve = Reserve + { rCurrency :: AssetClass, -- reserve id + rAToken :: AssetClass, + rAmount :: Integer, + rLiquidityIndex :: Integer, + rCurrentStableBorrowRate :: Rational, + rTrustedOracle :: (CurrencySymbol, PubKeyHash, Integer, AssetClass) + } + deriving stock (Prelude.Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON) + +PlutusTx.unstableMakeIsData ''Reserve +PlutusTx.makeLift ''Reserve +Lens.makeClassy_ ''Reserve + +-- TODO (?) only aTokens pledged as collateral should accumulate interest +-- data UserConfig = UserConfig +-- { ucDebt :: [IncentivizedAmount] +-- , ucCollateralizedInvestment :: [IncentivizedAmount] +-- } +-- data IncentivizedAmount = IncentivizedAmount +-- { iaAmount :: Integer +-- , iaRate :: Rational +-- , iaSlot :: Slot +-- } + +data UserConfig = UserConfig + { + ucDebt :: Integer, + ucCollateralizedInvestment :: Integer + } + deriving stock (Prelude.Eq, Show, Generic) + deriving anyclass (ToJSON, FromJSON, ToSchema) + +PlutusTx.unstableMakeIsData ''UserConfig +PlutusTx.makeLift ''UserConfig +Lens.makeClassy_ ''UserConfig + +data AaveRedeemer = + StartRedeemer + | DepositRedeemer (AssetClass, PubKeyHash) + | WithdrawRedeemer (AssetClass, PubKeyHash) + | BorrowRedeemer (AssetClass, PubKeyHash) [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] + | RepayRedeemer (AssetClass, PubKeyHash) + | ProvideCollateralRedeemer (AssetClass, PubKeyHash) + | RevokeCollateralRedeemer (AssetClass, PubKeyHash) AssetClass [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] + deriving Show + +PlutusTx.unstableMakeIsData ''AaveRedeemer +PlutusTx.makeLift ''AaveRedeemer + +-- TODO: solve purescript generation issue with type synonyms +type UserConfigId = (AssetClass, PubKeyHash) +type LendingPoolOperator = PubKeyHash +type Oracles = AssocMap.Map AssetClass Integer -- Shows how many lovelaces should be paid for a specific asset + +data AaveDatum = + LendingPoolDatum LendingPoolOperator + | ReservesDatum AssetClass (AssocMap.Map AssetClass Reserve) -- State token and reserve currency -> reserve map + | ReserveFundsDatum + | UserConfigsDatum AssetClass (AssocMap.Map (AssetClass, PubKeyHash) UserConfig) -- State token and UserConfigId -> user config map + | UserCollateralFundsDatum PubKeyHash AssetClass -- User pub key and aToken asset type + deriving stock (Show) + +PlutusTx.unstableMakeIsData ''AaveDatum +PlutusTx.makeLift ''AaveDatum +Lens.makeClassyPrisms ''AaveDatum + +data AaveScript +instance Scripts.ValidatorTypes AaveScript where + type instance RedeemerType AaveScript = AaveRedeemer + type instance DatumType AaveScript = AaveDatum diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/Core.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Validator.hs similarity index 59% rename from MetaLamp/lending-pool/src/Plutus/Contracts/Core.hs rename to MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Validator.hs index cb1687f15..775884cd2 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/Core.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Validator.hs @@ -14,35 +14,56 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} - -module Plutus.Contracts.Core where - -import Control.Lens ((^?)) -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.Text (Text, pack) -import Data.Void (Void) -import Ext.Plutus.Ledger.Contexts (findOnlyOneDatumHashByValue, - findValueByDatumHash, - parseDatum, scriptInputsAt, - valueSpentFrom) -import Ledger hiding (singleton) -import Ledger.Constraints as Constraints -import Ledger.Constraints.OnChain as Constraints -import Ledger.Constraints.TxConstraints as Constraints -import qualified Ledger.Scripts as UntypedScripts -import qualified Ledger.Typed.Scripts as Scripts +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fobject-code #-} + +module Plutus.Contracts.LendingPool.OnChain.Core.Validator (Aave(..), aaveInstance) where + +import Control.Lens ((^?)) +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.Text (Text, pack) +import Data.Void (Void) +import Ext.Plutus.Ledger.Contexts (findOnlyOneDatumHashByValue, + findValueByDatumHash, + parseDatum, + scriptInputsAt, + valueSpentFrom) +import Ledger hiding + (singleton) +import Ledger.Constraints as Constraints +import Ledger.Constraints.OnChain as Constraints +import Ledger.Constraints.TxConstraints as Constraints +import qualified Ledger.Scripts as UntypedScripts +import qualified Ledger.Typed.Scripts as Scripts import Playground.Contract -import Plutus.Contract hiding (when) -import qualified Plutus.Contracts.Oracle as Oracle +import Plutus.Contract hiding (when) +import Plutus.Contracts.LendingPool.OnChain.Core.Logic (areOraclesTrusted, + checkNegativeFundsTransformation, + checkNegativeReservesTransformation, + checkPositiveReservesTransformation, + doesCollateralCoverDebt, + pickReserves, + pickUserCollateralFunds, + pickUserConfigs) +import Plutus.Contracts.LendingPool.OnChain.Core.Script (AaveDatum (..), + AaveRedeemer (..), + AaveScript, + Reserve (..), + UserConfig (..)) +import qualified Plutus.Contracts.Service.Oracle as Oracle import Plutus.V1.Ledger.Value import qualified PlutusTx -import qualified PlutusTx.AssocMap as AssocMap -import PlutusTx.Prelude hiding (Semigroup (..), - unless) -import Prelude (Semigroup (..)) +import qualified PlutusTx.AssocMap as AssocMap +import PlutusTx.Prelude hiding + (Semigroup (..), + unless) +import Prelude (Semigroup (..)) import qualified Prelude newtype Aave = Aave @@ -52,135 +73,13 @@ newtype Aave = Aave PlutusTx.makeLift ''Aave -deriving anyclass instance ToSchema Rational - -data Reserve = Reserve - { rCurrency :: AssetClass, -- reserve id - rAToken :: AssetClass, - rAmount :: Integer, - rLiquidityIndex :: Integer, - rCurrentStableBorrowRate :: Rational, - rTrustedOracle :: (CurrencySymbol, PubKeyHash, Integer, AssetClass) - } - deriving stock (Prelude.Eq, Show, Generic) - deriving anyclass (ToJSON, FromJSON) - -PlutusTx.unstableMakeIsData ''Reserve -PlutusTx.makeLift ''Reserve -Lens.makeClassy_ ''Reserve - --- TODO (?) only aTokens pledged as collateral should accumulate interest --- data UserConfig = UserConfig --- { ucDebt :: [IncentivizedAmount] --- , ucCollateralizedInvestment :: [IncentivizedAmount] --- } --- data IncentivizedAmount = IncentivizedAmount --- { iaAmount :: Integer --- , iaRate :: Rational --- , iaSlot :: Slot --- } - -data UserConfig = UserConfig - { - ucDebt :: Integer, - ucCollateralizedInvestment :: Integer - } - deriving stock (Prelude.Eq, Show, Generic) - deriving anyclass (ToJSON, FromJSON, ToSchema) - -PlutusTx.unstableMakeIsData ''UserConfig -PlutusTx.makeLift ''UserConfig -Lens.makeClassy_ ''UserConfig - -data AaveRedeemer = - StartRedeemer - | DepositRedeemer (AssetClass, PubKeyHash) - | WithdrawRedeemer (AssetClass, PubKeyHash) - | BorrowRedeemer (AssetClass, PubKeyHash) [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] - | RepayRedeemer (AssetClass, PubKeyHash) - | ProvideCollateralRedeemer (AssetClass, PubKeyHash) - | RevokeCollateralRedeemer (AssetClass, PubKeyHash) AssetClass [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] - deriving Show - -PlutusTx.unstableMakeIsData ''AaveRedeemer -PlutusTx.makeLift ''AaveRedeemer - --- TODO: solve purescript generation issue with type synonyms -type UserConfigId = (AssetClass, PubKeyHash) -type LendingPoolOperator = PubKeyHash -type Oracles = AssocMap.Map AssetClass Integer -- Shows how many lovelaces should be paid for a specific asset - -data AaveDatum = - LendingPoolDatum LendingPoolOperator - | ReservesDatum AssetClass (AssocMap.Map AssetClass Reserve) -- State token and reserve currency -> reserve map - | ReserveFundsDatum - | UserConfigsDatum AssetClass (AssocMap.Map (AssetClass, PubKeyHash) UserConfig) -- State token and UserConfigId -> user config map - | UserCollateralFundsDatum PubKeyHash AssetClass -- User pub key and aToken asset type - deriving stock (Show) - -PlutusTx.unstableMakeIsData ''AaveDatum -PlutusTx.makeLift ''AaveDatum -Lens.makeClassyPrisms ''AaveDatum - -{-# INLINABLE pickUserConfigs #-} -pickUserConfigs :: AaveDatum -> Maybe (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig) -pickUserConfigs (UserConfigsDatum stateToken configs) = Just (stateToken, configs) -pickUserConfigs _ = Nothing - -{-# INLINABLE pickReserves #-} -pickReserves :: AaveDatum -> Maybe (AssetClass, AssocMap.Map AssetClass Reserve) -pickReserves (ReservesDatum stateToken configs) = Just (stateToken, configs) -pickReserves _ = Nothing - -{-# INLINABLE pickUserCollateralFunds #-} -pickUserCollateralFunds :: AaveDatum -> Maybe (PubKeyHash, AssetClass) -pickUserCollateralFunds (UserCollateralFundsDatum user aTokenAsset) = Just (user, aTokenAsset) -pickUserCollateralFunds _ = Nothing - -{-# INLINABLE totalDebtAndCollateralInLovelace #-} -totalDebtAndCollateralInLovelace :: - PubKeyHash - -> AssocMap.Map AssetClass Integer - -> AssocMap.Map (AssetClass, PubKeyHash) UserConfig - -> Maybe UserConfig -totalDebtAndCollateralInLovelace actor oracles userConfigs = - foldrM addCollateral (UserConfig 0 0) $ AssocMap.toList userConfigs - where - addCollateral :: - ((AssetClass, PubKeyHash), UserConfig) - -> UserConfig - -> Maybe UserConfig - addCollateral ((asset, user), userConfig) currentTotal - | user == actor = - (\rate -> UserConfig { - ucCollateralizedInvestment = rate * ucCollateralizedInvestment userConfig + ucCollateralizedInvestment currentTotal, - ucDebt = rate * ucDebt userConfig + ucDebt currentTotal } - ) <$> - AssocMap.lookup asset oracles - | otherwise = Just currentTotal - -{-# INLINABLE doesCollateralCoverDebt #-} -doesCollateralCoverDebt :: - PubKeyHash - -> AssocMap.Map AssetClass Integer - -> AssocMap.Map (AssetClass, PubKeyHash) UserConfig - -> Bool -doesCollateralCoverDebt actor oracles userConfigs = maybe False (\UserConfig{..} -> ucDebt <= ucCollateralizedInvestment) $ - totalDebtAndCollateralInLovelace actor oracles userConfigs - -{-# INLINABLE areOraclesTrusted #-} -areOraclesTrusted :: [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] - -> AssocMap.Map AssetClass Reserve - -> Bool -areOraclesTrusted oracles reserves = all checkOracle oracles +aaveInstance :: Aave -> Scripts.TypedValidator AaveScript +aaveInstance aave = Scripts.mkTypedValidator @AaveScript + ($$(PlutusTx.compile [|| makeAaveValidator ||]) + `PlutusTx.applyCode` PlutusTx.liftCode aave) + $$(PlutusTx.compile [|| wrap ||]) where - checkOracle o = let oracle = Oracle.fromTuple o in - Just oracle == (Oracle.fromTuple . rTrustedOracle <$> AssocMap.lookup (Oracle.oAsset oracle) reserves) - -data AaveScript -instance Scripts.ValidatorTypes AaveScript where - type instance RedeemerType AaveScript = AaveRedeemer - type instance DatumType AaveScript = AaveDatum + wrap = Scripts.wrapValidator @AaveDatum @AaveRedeemer {-# INLINABLE makeAaveValidator #-} -- Main validator @@ -203,6 +102,7 @@ makeAaveValidator aave datum (RepayRedeemer userConfigId) ctx = trace "RepayR makeAaveValidator aave datum (ProvideCollateralRedeemer userConfigId) ctx = trace "ProvideCollateralRedeemer" $ validateProvideCollateral aave datum ctx userConfigId makeAaveValidator aave datum (RevokeCollateralRedeemer userConfigId aTokenAsset oracles) ctx = trace "RevokeCollateralRedeemer" $ validateRevokeCollateral aave datum ctx userConfigId aTokenAsset oracles +{-# INLINABLE validateStart #-} validateStart :: Aave -> AaveDatum -> ScriptContext -> Bool validateStart aave (LendingPoolDatum operator) ctx = traceIfFalse "validateStart: Lending Pool Datum management is not authorized by operator" @@ -216,6 +116,7 @@ validateStart aave (LendingPoolDatum operator) ctx = outs -> isJust $ AssocMap.lookup scriptsDatumHash $ AssocMap.fromList outs validateStart aave _ ctx = trace "validateStart: Lending Pool Datum management is not allowed" False +{-# INLINABLE validateDeposit #-} validateDeposit :: Aave -> AaveDatum -> ScriptContext -> (AssetClass, PubKeyHash) -> Bool validateDeposit aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId = traceIfFalse "validateDeposit: User Configs Datum change is not valid" isValidUserConfigsTransformation @@ -250,6 +151,7 @@ validateDeposit aave (ReservesDatum stateToken reserves) ctx userConfigId = validateDeposit _ _ _ _ = trace "validateDeposit: Lending Pool Datum management is not allowed" False +{-# INLINABLE validateWithdraw #-} validateWithdraw :: Aave -> AaveDatum -> ScriptContext -> (AssetClass, PubKeyHash) -> Bool validateWithdraw aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId = -- TODO add implementation for this case @@ -262,6 +164,7 @@ validateWithdraw aave ReserveFundsDatum ctx (reserveId, actor) = validateWithdraw _ _ _ _ = trace "validateWithdraw: Lending Pool Datum management is not allowed" False +{-# INLINABLE validateBorrow #-} validateBorrow :: Aave -> AaveDatum -> ScriptContext -> (AssetClass, PubKeyHash) -> [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] -> Bool validateBorrow aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(reserveId, actor) oracles = traceIfFalse "validateBorrow: User Configs Datum change is not valid" isValidUserConfigsTransformation @@ -307,6 +210,7 @@ validateBorrow aave ReserveFundsDatum ctx (reserveId, actor) oracles = validateBorrow _ _ _ _ _ = trace "validateBorrow: Lending Pool Datum management is not allowed" False +{-# INLINABLE validateRepay #-} validateRepay :: Aave -> AaveDatum -> ScriptContext -> (AssetClass, PubKeyHash) -> Bool validateRepay aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(reserveId, actor) = traceIfFalse "validateRepay: User Configs Datum change is not valid" isValidUserConfigsTransformation @@ -345,6 +249,7 @@ validateRepay aave (ReservesDatum stateToken reserves) ctx userConfigId = validateRepay _ _ _ _ = trace "validateRepay: Lending Pool Datum management is not allowed" False +{-# INLINABLE validateProvideCollateral #-} validateProvideCollateral :: Aave -> AaveDatum -> ScriptContext -> (AssetClass, PubKeyHash) -> Bool validateProvideCollateral aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(reserveId, actor) = traceIfFalse "validateProvideCollateral: User Configs Datum change is not valid" isValidUserConfigsTransformation @@ -387,6 +292,7 @@ validateProvideCollateral aave (UserConfigsDatum stateToken userConfigs) ctx us validateProvideCollateral _ _ _ _ = trace "validateProvideCollateral: Lending Pool Datum management is not allowed" False +{-# INLINABLE validateRevokeCollateral #-} validateRevokeCollateral :: Aave -> AaveDatum -> ScriptContext -> (AssetClass, PubKeyHash) -> AssetClass -> [(CurrencySymbol, PubKeyHash, Integer, AssetClass)] -> Bool validateRevokeCollateral aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(reserveId, actor) aTokenAsset oracles = traceIfFalse "validateRevokeCollateral: User Configs Datum change is not valid" isValidUserConfigsTransformation @@ -434,119 +340,3 @@ validateRevokeCollateral aave (ReservesDatum stateToken reserves) ctx userConfig traceIfFalse "validateRevokeCollateral: Reserves Datum change is not valid" $ areOraclesTrusted oracles reserves validateRevokeCollateral _ _ _ _ _ _ = trace "validateRevokeCollateral: Lending Pool Datum management is not allowed" False - -checkNegativeFundsTransformation :: ScriptContext -> AssetClass -> PubKeyHash -> Bool -checkNegativeFundsTransformation ctx asset actor = isValidFundsChange - where - txInfo = scriptContextTxInfo ctx - (scriptsHash, scriptsDatumHash) = ownHashes ctx - scriptOutputs = scriptOutputsAt scriptsHash txInfo - - scriptSpentValue = findValueByDatumHash scriptsDatumHash $ scriptInputsAt scriptsHash txInfo - scriptRemainderValue = findValueByDatumHash scriptsDatumHash scriptOutputs - actorSpentValue = valueSpentFrom txInfo actor - actorRemainderValue = valuePaidTo txInfo actor - - isValidFundsChange :: Bool - isValidFundsChange = - let paidAmout = assetClassValueOf actorRemainderValue asset - assetClassValueOf actorSpentValue asset - fundsChange = assetClassValueOf scriptSpentValue asset - assetClassValueOf scriptRemainderValue asset - in fundsChange == paidAmout && fundsChange > 0 && paidAmout > 0 - -checkNegativeReservesTransformation :: AssetClass - -> AssocMap.Map AssetClass Reserve - -> ScriptContext - -> (AssetClass, PubKeyHash) - -> Bool -checkNegativeReservesTransformation stateToken reserves ctx (reserveId, _) = - maybe False checkreserves reservesOutputDatum - where - txInfo = scriptContextTxInfo ctx - (scriptsHash, scriptsDatumHash) = ownHashes ctx - scriptOutputs = scriptOutputsAt scriptsHash txInfo - - reservesOutputDatumHash = - findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs - reservesOutputDatum :: - Maybe (AssetClass, AssocMap.Map AssetClass Reserve) - reservesOutputDatum = - reservesOutputDatumHash >>= parseDatum txInfo >>= pickReserves - - remainderDatumHash = findDatumHash (Datum $ PlutusTx.toData ReserveFundsDatum) txInfo - remainderValue = (`findValueByDatumHash` scriptOutputs) <$> remainderDatumHash - - checkreserves :: (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool - checkreserves (newStateToken, newReserves) = - newStateToken == stateToken && - maybe - False - checkReserveState - ((,,) <$> remainderValue <*> AssocMap.lookup reserveId reserves <*> AssocMap.lookup reserveId newReserves) - checkReserveState :: (Value, Reserve, Reserve) -> Bool - checkReserveState (value, oldState, newState) = - let fundsAmount = rAmount newState - in assetClassValueOf value reserveId == fundsAmount && fundsAmount >= 0 && checkReservesConsistency oldState newState - -checkPositiveReservesTransformation :: AssetClass - -> AssocMap.Map AssetClass Reserve - -> ScriptContext - -> (AssetClass, PubKeyHash) - -> Bool -checkPositiveReservesTransformation stateToken reserves ctx (reserveId, _) = maybe False checkreserves reservesOutputDatum - where - txInfo = scriptContextTxInfo ctx - (scriptsHash, scriptsDatumHash) = ownHashes ctx - scriptOutputs = scriptOutputsAt scriptsHash txInfo - - reservesOutputDatumHash = - findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs - reservesOutputDatum :: - Maybe (AssetClass, AssocMap.Map AssetClass Reserve) - reservesOutputDatum = - reservesOutputDatumHash >>= parseDatum txInfo >>= pickReserves - - investmentDatumHash = findDatumHash (Datum $ PlutusTx.toData ReserveFundsDatum) txInfo - investmentValue = (`findValueByDatumHash` scriptOutputs) <$> investmentDatumHash - - checkreserves :: (AssetClass, AssocMap.Map AssetClass Reserve) -> Bool - checkreserves (newStateToken, newReserves) = - newStateToken == stateToken && - maybe - False - checkReserveState - ((,,) <$> investmentValue <*> AssocMap.lookup reserveId reserves <*> AssocMap.lookup reserveId newReserves) - checkReserveState :: (Value, Reserve, Reserve) -> Bool - checkReserveState (value, oldState, newState) = - let fundsChange = rAmount newState - rAmount oldState - in assetClassValueOf value reserveId == fundsChange && fundsChange > 0 && checkReservesConsistency oldState newState - -checkReservesConsistency :: Reserve -> Reserve -> Bool -checkReservesConsistency oldState newState = - rCurrency oldState == rCurrency newState && - rAToken oldState == rAToken newState && - rLiquidityIndex oldState == rLiquidityIndex newState && - rCurrentStableBorrowRate oldState == rCurrentStableBorrowRate newState && - Oracle.fromTuple (rTrustedOracle oldState) == Oracle.fromTuple (rTrustedOracle newState) - -aaveProtocolName :: TokenName -aaveProtocolName = "Aave" - -aaveInstance :: Aave -> Scripts.TypedValidator AaveScript -aaveInstance aave = Scripts.mkTypedValidator @AaveScript - ($$(PlutusTx.compile [|| makeAaveValidator ||]) - `PlutusTx.applyCode` PlutusTx.liftCode aave) - $$(PlutusTx.compile [|| wrap ||]) - where - wrap = Scripts.wrapValidator @AaveDatum @AaveRedeemer - -aaveValidator :: Aave -> Validator -aaveValidator = Scripts.validatorScript . aaveInstance - -aaveHash :: Aave -> Ledger.ValidatorHash -aaveHash = UntypedScripts.validatorHash . aaveValidator - -aaveAddress :: Aave -> Ledger.Address -aaveAddress = Ledger.scriptAddress . aaveValidator - -aave :: CurrencySymbol -> Aave -aave protocol = Aave (assetClass protocol aaveProtocolName) diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/FungibleToken.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/Service/FungibleToken.hs similarity index 87% rename from MetaLamp/lending-pool/src/Plutus/Contracts/FungibleToken.hs rename to MetaLamp/lending-pool/src/Plutus/Contracts/Service/FungibleToken.hs index fa44b7ebd..4acdc6663 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/FungibleToken.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/Service/FungibleToken.hs @@ -2,13 +2,13 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TemplateHaskell #-} -module Plutus.Contracts.FungibleToken where +module Plutus.Contracts.Service.FungibleToken where import Ledger.Typed.Scripts (MonetaryPolicy) import qualified Ledger.Typed.Scripts as Scripts import Plutus.V1.Ledger.Contexts (ScriptContext) import qualified Plutus.V1.Ledger.Scripts as Scripts -import Plutus.V1.Ledger.Value (TokenName, Value) +import Plutus.V1.Ledger.Value (TokenName) import qualified PlutusTx import PlutusTx.Prelude diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/Oracle.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/Service/Oracle.hs similarity index 97% rename from MetaLamp/lending-pool/src/Plutus/Contracts/Oracle.hs rename to MetaLamp/lending-pool/src/Plutus/Contracts/Service/Oracle.hs index 472f6974a..438ae2c4e 100644 --- a/MetaLamp/lending-pool/src/Plutus/Contracts/Oracle.hs +++ b/MetaLamp/lending-pool/src/Plutus/Contracts/Service/Oracle.hs @@ -15,7 +15,7 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-specialise #-} -module Plutus.Contracts.Oracle +module Plutus.Contracts.Service.Oracle ( Oracle (..) , OracleRedeemer (..) , oracleTokenName @@ -47,15 +47,13 @@ import Ledger.Ada as Ada import Ledger.Constraints as Constraints import qualified Ledger.Typed.Scripts as Scripts import Ledger.Value as Value +import qualified Plutus.Abstract.TxUtils as TxUtils import Plutus.Contract as Contract hiding (when) import Plutus.Contracts.Currency as Currency -import qualified Plutus.Contracts.TxUtils as TxUtils -import Plutus.OutputValue -import qualified Plutus.State.Select as Select import qualified PlutusTx import PlutusTx.Prelude hiding (Semigroup (..), unless) import Prelude (Semigroup (..)) -import qualified Prelude as Prelude +import qualified Prelude import Schema (ToSchema) data Oracle = Oracle diff --git a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs index 0d0519225..3d4a129d4 100644 --- a/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs +++ b/MetaLamp/lending-pool/src/Plutus/PAB/Simulation.hs @@ -13,50 +13,61 @@ module Plutus.PAB.Simulation where -import Control.Monad (forM, forM_, void, when) -import Control.Monad.Freer (Eff, Member, interpret, - type (~>)) -import Control.Monad.Freer.Error (Error) -import Control.Monad.Freer.Extras.Log (LogMsg) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Aeson (FromJSON, Result (..), - ToJSON, encode, fromJSON) -import qualified Data.ByteString as BS -import qualified Data.Map.Strict as Map -import qualified Data.Monoid as Monoid -import qualified Data.Semigroup as Semigroup -import Data.Text (Text) -import Data.Text.Prettyprint.Doc (Pretty (..), viaShow) -import GHC.Generics (Generic) +import Control.Monad (forM, forM_, void, + when) +import Control.Monad.Freer (Eff, Member, + interpret, + type (~>)) +import Control.Monad.Freer.Error (Error) +import Control.Monad.Freer.Extras.Log (LogMsg) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Aeson (FromJSON, + Result (..), + ToJSON, encode, + fromJSON) +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as Map +import qualified Data.Monoid as Monoid +import qualified Data.Semigroup as Semigroup +import Data.Text (Text) +import Data.Text.Prettyprint.Doc (Pretty (..), + viaShow) +import GHC.Generics (Generic) import Ledger -import Ledger.Ada (adaSymbol, adaToken, - adaValueOf, - lovelaceValueOf) +import Ledger.Ada (adaSymbol, + adaToken, + adaValueOf, + lovelaceValueOf) import Ledger.Constraints -import qualified Ledger.Constraints.OffChain as Constraints -import qualified Ledger.Typed.Scripts as Scripts -import Ledger.Value as Value -import Plutus.Contract hiding (when) -import qualified Plutus.Contracts.Core as Aave -import Plutus.Contracts.Currency as Currency -import Plutus.Contracts.Endpoints (ContractResponse (..)) -import qualified Plutus.Contracts.Endpoints as Aave -import qualified Plutus.Contracts.FungibleToken as FungibleToken -import qualified Plutus.Contracts.Oracle as Oracle -import Plutus.PAB.Effects.Contract (ContractEffect (..)) -import Plutus.PAB.Effects.Contract.Builtin (Builtin, SomeBuiltin (..), - type (.\\)) -import qualified Plutus.PAB.Effects.Contract.Builtin as Builtin -import Plutus.PAB.Monitoring.PABLogMsg (PABMultiAgentMsg) -import Plutus.PAB.Simulator (Simulation, - SimulatorEffectHandlers) -import qualified Plutus.PAB.Simulator as Simulator -import Plutus.PAB.Types (PABError (..)) -import qualified Plutus.PAB.Webserver.Server as PAB.Server -import Plutus.V1.Ledger.Crypto (getPubKeyHash, pubKeyHash) -import Prelude hiding (init) -import Wallet.Emulator.Types (Wallet (..), walletPubKey) -import Wallet.Types (ContractInstanceId) +import qualified Ledger.Constraints.OffChain as Constraints +import qualified Ledger.Typed.Scripts as Scripts +import Ledger.Value as Value +import Plutus.Abstract.ContractResponse (ContractResponse (..)) +import Plutus.Contract hiding (when) +import Plutus.Contracts.Currency as Currency +import qualified Plutus.Contracts.LendingPool.OffChain.Info as Aave +import qualified Plutus.Contracts.LendingPool.OffChain.Owner as Aave +import qualified Plutus.Contracts.LendingPool.OffChain.User as Aave +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Aave +import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken +import qualified Plutus.Contracts.Service.Oracle as Oracle +import Plutus.PAB.Effects.Contract (ContractEffect (..)) +import Plutus.PAB.Effects.Contract.Builtin (Builtin, + SomeBuiltin (..), + type (.\\)) +import qualified Plutus.PAB.Effects.Contract.Builtin as Builtin +import Plutus.PAB.Monitoring.PABLogMsg (PABMultiAgentMsg) +import Plutus.PAB.Simulator (Simulation, + SimulatorEffectHandlers) +import qualified Plutus.PAB.Simulator as Simulator +import Plutus.PAB.Types (PABError (..)) +import qualified Plutus.PAB.Webserver.Server as PAB.Server +import Plutus.V1.Ledger.Crypto (getPubKeyHash, + pubKeyHash) +import Prelude hiding (init) +import Wallet.Emulator.Types (Wallet (..), + walletPubKey) +import Wallet.Types (ContractInstanceId) ownerWallet :: Wallet ownerWallet = Wallet 1 diff --git a/MetaLamp/lending-pool/test/Fixtures.hs b/MetaLamp/lending-pool/test/Fixtures.hs index 50346037d..aa61a44d4 100644 --- a/MetaLamp/lending-pool/test/Fixtures.hs +++ b/MetaLamp/lending-pool/test/Fixtures.hs @@ -1,6 +1,6 @@ -module Fixtures (module Fixtures.Aave, module Fixtures.Asset, module Fixtures.Init, module Fixtures.Wallet) where +module Fixtures (module Export) where -import Fixtures.Aave -import Fixtures.Asset -import Fixtures.Init -import Fixtures.Wallet +import Fixtures.Aave as Export +import Fixtures.Asset as Export +import Fixtures.Init as Export +import Fixtures.Wallet as Export diff --git a/MetaLamp/lending-pool/test/Fixtures/Aave.hs b/MetaLamp/lending-pool/test/Fixtures/Aave.hs index 4b5ea3be9..95a376269 100644 --- a/MetaLamp/lending-pool/test/Fixtures/Aave.hs +++ b/MetaLamp/lending-pool/test/Fixtures/Aave.hs @@ -5,14 +5,15 @@ module Fixtures.Aave where -import Data.Text (Text) -import Fixtures.Symbol (forgeSymbol, getSymbol) +import Data.Text (Text) +import Fixtures.Symbol (forgeSymbol, + getSymbol) import qualified Ledger +import qualified Plutus.Abstract.TxUtils as TxUtils 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 qualified Plutus.Contracts.LendingPool.OffChain.Owner as Aave +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Aave +import Plutus.V1.Ledger.Value (CurrencySymbol) import PlutusTx.Prelude aaveSymbol :: CurrencySymbol diff --git a/MetaLamp/lending-pool/test/Fixtures/Asset.hs b/MetaLamp/lending-pool/test/Fixtures/Asset.hs index e5e206487..032e909cd 100644 --- a/MetaLamp/lending-pool/test/Fixtures/Asset.hs +++ b/MetaLamp/lending-pool/test/Fixtures/Asset.hs @@ -2,10 +2,10 @@ 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) +import qualified Fixtures.Aave as AaveMock +import qualified Plutus.Contracts.LendingPool.OnChain.AToken as AToken +import Plutus.PAB.Simulation (toAsset) +import Plutus.V1.Ledger.Value (AssetClass) mogus :: AssetClass mogus = toAsset "MOGUS" diff --git a/MetaLamp/lending-pool/test/Fixtures/Init.hs b/MetaLamp/lending-pool/test/Fixtures/Init.hs index 5d1d50684..a690d050f 100644 --- a/MetaLamp/lending-pool/test/Fixtures/Init.hs +++ b/MetaLamp/lending-pool/test/Fixtures/Init.hs @@ -2,28 +2,32 @@ module Fixtures.Init where -import Control.Monad (forM, forM_, void) -import qualified Data.Map as Map -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 Control.Monad (forM, forM_, void) +import qualified Data.Map as Map +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.Abstract.ContractResponse (ContractResponse (..)) 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) +import qualified Plutus.Contracts.LendingPool.OffChain.Owner as Aave +import qualified Plutus.Contracts.LendingPool.OffChain.User as Aave +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Aave +import qualified Plutus.Contracts.Service.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 diff --git a/MetaLamp/lending-pool/test/Fixtures/Symbol.hs b/MetaLamp/lending-pool/test/Fixtures/Symbol.hs index f7112a897..f765c3f74 100644 --- a/MetaLamp/lending-pool/test/Fixtures/Symbol.hs +++ b/MetaLamp/lending-pool/test/Fixtures/Symbol.hs @@ -13,8 +13,8 @@ import qualified Ledger import qualified Ledger.Constraints as Constraints import Ledger.Typed.Scripts (MonetaryPolicy) import qualified Ledger.Typed.Scripts as Scripts +import qualified Plutus.Abstract.TxUtils as TxUtils 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, diff --git a/MetaLamp/lending-pool/test/Spec/Borrow.hs b/MetaLamp/lending-pool/test/Spec/Borrow.hs index 4e9ce0878..9f5cea74b 100644 --- a/MetaLamp/lending-pool/test/Spec/Borrow.hs +++ b/MetaLamp/lending-pool/test/Spec/Borrow.hs @@ -5,20 +5,21 @@ module Spec.Borrow where -import Control.Lens (over) -import qualified Data.Map as Map +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 qualified Plutus.Contracts.LendingPool.OffChain.User as Aave +import qualified Plutus.Contracts.LendingPool.OnChain.Core 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 +import qualified Utils.Data as Utils tests :: TestTree tests = testGroup "borrow" [ diff --git a/MetaLamp/lending-pool/test/Spec/Deposit.hs b/MetaLamp/lending-pool/test/Spec/Deposit.hs index 8b1912c08..d6bce9936 100644 --- a/MetaLamp/lending-pool/test/Spec/Deposit.hs +++ b/MetaLamp/lending-pool/test/Spec/Deposit.hs @@ -5,18 +5,19 @@ module Spec.Deposit where -import Control.Lens (over) -import qualified Data.Map as Map +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 qualified Plutus.Contracts.LendingPool.OffChain.User as Aave +import qualified Plutus.Contracts.LendingPool.OnChain.Core 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 +import qualified Utils.Data as Utils tests :: TestTree tests = testGroup "deposit" [ diff --git a/MetaLamp/lending-pool/test/Spec/ProvideCollateral.hs b/MetaLamp/lending-pool/test/Spec/ProvideCollateral.hs index 2781bf2c0..d19aaf695 100644 --- a/MetaLamp/lending-pool/test/Spec/ProvideCollateral.hs +++ b/MetaLamp/lending-pool/test/Spec/ProvideCollateral.hs @@ -5,19 +5,20 @@ module Spec.ProvideCollateral where -import Control.Lens (over) -import qualified Data.Map as Map +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 qualified Plutus.Contracts.LendingPool.OffChain.User as Aave +import qualified Plutus.Contracts.LendingPool.OnChain.Core 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 +import qualified Utils.Data as Utils tests :: TestTree tests = testGroup "provideCollateral" [ diff --git a/MetaLamp/lending-pool/test/Spec/Repay.hs b/MetaLamp/lending-pool/test/Spec/Repay.hs index d6a4c3993..8a43d8804 100644 --- a/MetaLamp/lending-pool/test/Spec/Repay.hs +++ b/MetaLamp/lending-pool/test/Spec/Repay.hs @@ -5,21 +5,22 @@ module Spec.Repay where -import Control.Lens (over) -import qualified Data.Map as Map +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 qualified Plutus.Contracts.LendingPool.OffChain.User as Aave +import qualified Plutus.Contracts.LendingPool.OnChain.Core 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 +import qualified Utils.Data as Utils tests :: TestTree tests = testGroup "repay" [ diff --git a/MetaLamp/lending-pool/test/Spec/RevokeCollateral.hs b/MetaLamp/lending-pool/test/Spec/RevokeCollateral.hs index 481b47f78..fd73eabb5 100644 --- a/MetaLamp/lending-pool/test/Spec/RevokeCollateral.hs +++ b/MetaLamp/lending-pool/test/Spec/RevokeCollateral.hs @@ -5,20 +5,21 @@ module Spec.RevokeCollateral where -import Control.Lens (over) -import qualified Data.Map as Map +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 qualified Plutus.Contracts.LendingPool.OffChain.User as Aave +import qualified Plutus.Contracts.LendingPool.OnChain.Core 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 +import qualified Utils.Data as Utils tests :: TestTree tests = testGroup "revokeCollateral" [ diff --git a/MetaLamp/lending-pool/test/Spec/Shared.hs b/MetaLamp/lending-pool/test/Spec/Shared.hs index 19bb98e98..292f133f5 100644 --- a/MetaLamp/lending-pool/test/Spec/Shared.hs +++ b/MetaLamp/lending-pool/test/Spec/Shared.hs @@ -4,13 +4,13 @@ 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 +import Plutus.Contract.Test (TracePredicate) +import qualified Plutus.Contracts.LendingPool.OnChain.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) diff --git a/MetaLamp/lending-pool/test/Spec/Start.hs b/MetaLamp/lending-pool/test/Spec/Start.hs index bdcf491e7..cc9eeacdc 100644 --- a/MetaLamp/lending-pool/test/Spec/Start.hs +++ b/MetaLamp/lending-pool/test/Spec/Start.hs @@ -5,10 +5,10 @@ module Spec.Start where import qualified Fixtures import Plutus.Contract.Test -import qualified Plutus.Contracts.Core as Aave +import qualified Plutus.Contracts.LendingPool.OnChain.Core as Aave import Test.Tasty -import qualified Utils.Data as Utils -import qualified Utils.Trace as Utils +import qualified Utils.Data as Utils +import qualified Utils.Trace as Utils tests :: TestTree tests = testGroup "start" [checkPredicate diff --git a/MetaLamp/lending-pool/test/Spec/Withdraw.hs b/MetaLamp/lending-pool/test/Spec/Withdraw.hs index a130ae3e3..acfbd225a 100644 --- a/MetaLamp/lending-pool/test/Spec/Withdraw.hs +++ b/MetaLamp/lending-pool/test/Spec/Withdraw.hs @@ -5,19 +5,20 @@ module Spec.Withdraw where -import Control.Lens (over) -import qualified Data.Map as Map +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 qualified Plutus.Contracts.LendingPool.OffChain.User as Aave +import qualified Plutus.Contracts.LendingPool.OnChain.Core 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 +import qualified Utils.Data as Utils tests :: TestTree tests = testGroup "withdraw" [ diff --git a/MetaLamp/lending-pool/test/Utils/Data.hs b/MetaLamp/lending-pool/test/Utils/Data.hs index 8fa6693de..71c620c55 100644 --- a/MetaLamp/lending-pool/test/Utils/Data.hs +++ b/MetaLamp/lending-pool/test/Utils/Data.hs @@ -1,11 +1,11 @@ module Utils.Data where -import Data.Function ((&)) -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) +import Data.Function ((&)) +import Plutus.Abstract.ContractResponse (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 diff --git a/MetaLamp/lending-pool/test/Utils/Trace.hs b/MetaLamp/lending-pool/test/Utils/Trace.hs index 8f9c73412..603219669 100644 --- a/MetaLamp/lending-pool/test/Utils/Trace.hs +++ b/MetaLamp/lending-pool/test/Utils/Trace.hs @@ -5,29 +5,28 @@ 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 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 Data.Map as Map +import Data.Maybe (mapMaybe) +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) +import Ledger.AddressMap (UtxoMap) +import Plutus.Abstract.ContractResponse (ContractResponse (..)) +import Plutus.Contract (HasBlockchainActions) +import Plutus.Contract.Test (TracePredicate) +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