Skip to content

Commit f57adab

Browse files
performanceArtistperformanceArtist
committed
Implement incentivized tokens
1 parent bbfa664 commit f57adab

File tree

12 files changed

+475
-383
lines changed

12 files changed

+475
-383
lines changed

‎MetaLamp/lending-pool/generate-purs/AaveTypes.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ import Language.PureScript.Bridge.Builder (BridgeData)
3131
import Language.PureScript.Bridge.TypeParameters (A, E)
3232
import qualified PSGenerator.Common
3333
import Plutus.Abstract.ContractResponse (ContractResponse)
34+
import Plutus.Abstract.IncentivizedAmount (IncentivizedAmount)
3435
import qualified Plutus.Contracts.LendingPool.OffChain.Info as Aave
3536
import qualified Plutus.Contracts.LendingPool.OffChain.Owner as Aave
3637
import qualified Plutus.Contracts.LendingPool.OffChain.User as Aave
@@ -52,6 +53,7 @@ psRatio = expand <$> psTypeParameters
5253

5354
aaveTypes :: [SumType 'Haskell]
5455
aaveTypes = [ (equal <*> (genericShow <*> mkSumType)) (Proxy @AaveContracts)
56+
, (equal <*> (genericShow <*> mkSumType)) (Proxy @IncentivizedAmount)
5557
, (equal <*> (genericShow <*> mkSumType)) (Proxy @Aave.Aave)
5658
, (equal <*> (genericShow <*> mkSumType)) (Proxy @Oracle.Oracle)
5759
, (equal <*> (genericShow <*> mkSumType)) (Proxy @(ContractResponse E A))

‎MetaLamp/lending-pool/plutus-starter.cabal‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ maintainer: Your email
2323

2424
library
2525
exposed-modules:
26-
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
26+
Plutus.Abstract.State Plutus.Abstract.State.Select Plutus.Abstract.State.Update Plutus.Abstract.ContractResponse Plutus.Abstract.OutputValue Plutus.Abstract.TxUtils Plutus.Abstract.IncentivizedAmount Plutus.Contracts.Service.FungibleToken Plutus.Contracts.Service.Oracle Plutus.Contracts.LendingPool.Shared 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
2727
build-depends:
2828
base >= 4.9 && < 5,
2929
aeson,

‎MetaLamp/lending-pool/src/Ext/Plutus/Ledger/Contexts.hs‎

Lines changed: 26 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -4,20 +4,28 @@
44

55
module Ext.Plutus.Ledger.Contexts where
66

7-
import Ledger (Address (Address),
8-
Datum (getDatum), DatumHash,
9-
PubKeyHash,
7+
import Ledger (Address (Address), Datum (..),
8+
DatumHash, PubKeyHash,
9+
ScriptContext,
1010
TxInInfo (txInInfoResolved),
1111
TxInfo (txInfoInputs),
1212
TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue),
13-
ValidatorHash, Value, findDatum)
13+
ValidatorHash, Value, findDatum,
14+
findDatumHash, ownHashes,
15+
scriptContextTxInfo,
16+
scriptOutputsAt)
17+
import Plutus.V1.Ledger.Contexts (ScriptContext)
1418
import Plutus.V1.Ledger.Credential (Credential (PubKeyCredential, ScriptCredential))
1519
import qualified PlutusTx
1620
import PlutusTx.Prelude (Eq ((==)), Maybe (..), filter,
1721
find, fst, mapMaybe, mconcat,
1822
otherwise, snd, ($), (.), (<$>),
1923
(>>=))
2024

25+
{-# INLINABLE findOnlyOneDatumByValue #-}
26+
findOnlyOneDatumByValue :: PlutusTx.IsData a => ScriptContext -> Value -> Maybe a
27+
findOnlyOneDatumByValue ctx value = findOnlyOneDatumHashByValue value (getScriptOutputs ctx) >>= parseDatum (scriptContextTxInfo ctx)
28+
2129
{-# INLINABLE findOnlyOneDatumHashByValue #-}
2230
-- | Find the hash of a datum, if it is part of the script's outputs.
2331
-- Assume search failed if more than one correspondence is found.
@@ -28,6 +36,20 @@ findOnlyOneDatumHashByValue val outs = fst <$> case filter f outs of
2836
where
2937
f (_, val') = val' == val
3038

39+
{-# INLINABLE getScriptOutputs #-}
40+
getScriptOutputs :: ScriptContext -> [(DatumHash, Value)]
41+
getScriptOutputs ctx = scriptOutputsAt scriptsHash (scriptContextTxInfo ctx)
42+
where
43+
(scriptsHash, _) = ownHashes ctx
44+
45+
{-# INLINABLE findValueByDatum #-}
46+
findValueByDatum :: PlutusTx.IsData a => ScriptContext -> a -> Maybe Value
47+
findValueByDatum ctx datum = (`findValueByDatumHash` scriptOutputs) <$> findDatumHash (Datum $ PlutusTx.toData datum) txInfo
48+
where
49+
txInfo = scriptContextTxInfo ctx
50+
(scriptsHash, _) = ownHashes ctx
51+
scriptOutputs = scriptOutputsAt scriptsHash txInfo
52+
3153
{-# INLINABLE findValueByDatumHash #-}
3254
-- | Concat value of the script's outputs that have the specified hash of a datum
3355
findValueByDatumHash :: DatumHash -> [(DatumHash, Value)] -> Value

‎MetaLamp/lending-pool/src/Plutus/Abstract/IncentivizedAmount.hs‎

Lines changed: 44 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,44 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE DeriveFunctor #-}
4+
{-# LANGUAGE DeriveGeneric #-}
5+
{-# LANGUAGE DerivingStrategies #-}
6+
{-# LANGUAGE FlexibleContexts #-}
7+
{-# LANGUAGE FlexibleInstances #-}
8+
{-# LANGUAGE MultiParamTypeClasses #-}
9+
{-# LANGUAGE NoImplicitPrelude #-}
10+
{-# LANGUAGE OverloadedStrings #-}
11+
{-# LANGUAGE ScopedTypeVariables #-}
12+
{-# LANGUAGE TemplateHaskell #-}
13+
{-# LANGUAGE TypeFamilies #-}
14+
{-# OPTIONS_GHC -fno-specialise #-}
15+
{-# OPTIONS_GHC -fno-strictness #-}
16+
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
17+
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
18+
{-# OPTIONS_GHC -fobject-code #-}
19+
20+
module Plutus.Abstract.IncentivizedAmount where
21+
22+
import qualified Control.Lens as Lens
23+
import Data.Aeson (FromJSON, ToJSON)
24+
import GHC.Generics
25+
import qualified Plutus.Abstract.TxUtils as TxUtils
26+
import Plutus.V1.Ledger.Slot (Slot (..))
27+
import qualified PlutusTx
28+
import PlutusTx.Prelude
29+
import PlutusTx.Ratio (Ratio)
30+
import qualified Prelude
31+
import Schema (ToSchema)
32+
33+
data IncentivizedAmount = IncentivizedAmount{ iaSlot :: Slot, iaRate :: Rational, iaAmount :: Rational }
34+
deriving stock (Prelude.Eq, Prelude.Show, Generic)
35+
deriving anyclass (ToJSON, FromJSON)
36+
37+
Lens.makeClassy_ ''IncentivizedAmount
38+
39+
instance Eq IncentivizedAmount where
40+
a == b = iaSlot a == iaSlot b && iaAmount a == iaAmount b && iaRate a == iaRate b
41+
42+
{-# INLINABLE accrue #-}
43+
accrue :: Rational -> Slot -> IncentivizedAmount -> IncentivizedAmount
44+
accrue newRate newSlot (IncentivizedAmount oldSlot oldRate amount) = IncentivizedAmount newSlot newRate (amount * oldRate)

‎MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/Owner.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -83,7 +83,8 @@ createReserve aave CreateParams {..} =
8383
rAmount = 0,
8484
rAToken = AToken.makeAToken (Core.aaveHash aave) cpAsset,
8585
rLiquidityIndex = 1,
86-
rCurrentStableBorrowRate = 11 % 10, -- TODO configure borrow rate when lending core will be ready
86+
rCurrentStableBorrowRate = 101 % 100,
87+
rCurrentStableAccrualRate = 101 % 100,
8788
rTrustedOracle = Oracle.toTuple cpOracle
8889
}
8990

‎MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/State.hs‎

Lines changed: 6 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,7 @@ import Plutus.Contracts.LendingPool.OnChain.Core (Aave (..),
4040
AaveScript,
4141
Reserve (..),
4242
UserConfig (..),
43-
UserConfigId)
43+
UserConfigId, getAaveState, reserveStateToken, userStateToken)
4444
import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core
4545
import qualified Plutus.Contracts.Service.FungibleToken as FungibleToken
4646
import Plutus.V1.Ledger.Ada (adaValueOf,
@@ -54,6 +54,7 @@ import PlutusTx.Prelude hiding (Functor (..),
5454
import Prelude (Semigroup (..),
5555
fmap)
5656
import qualified Prelude
57+
import Plutus.Abstract.IncentivizedAmount (accrue)
5758

5859
findOutputsBy :: Aave -> AssetClass -> (AaveDatum -> Maybe a) -> Contract w s Text [OutputValue a]
5960
findOutputsBy aave = State.findOutputsBy (Core.aaveAddress aave)
@@ -64,10 +65,6 @@ findOutputBy aave = State.findOutputBy (Core.aaveAddress aave)
6465
findAaveOwnerToken :: Aave -> Contract w s Text (OutputValue PubKeyHash)
6566
findAaveOwnerToken aave@Aave{..} = findOutputBy aave aaveProtocolInst (^? Core._LendingPoolDatum)
6667

67-
reserveStateToken, userStateToken :: Aave -> AssetClass
68-
reserveStateToken aave = State.makeStateToken (Core.aaveHash aave) (aaveProtocolInst aave) "aaveReserve"
69-
userStateToken aave = State.makeStateToken (Core.aaveHash aave) (aaveProtocolInst aave) "aaveUser"
70-
7168
findAaveReserves :: Aave -> Contract w s Text (OutputValue (AssocMap.Map AssetClass Reserve))
7269
findAaveReserves aave = findOutputBy aave (reserveStateToken aave) (^? Core._ReservesDatum . _2)
7370

@@ -97,10 +94,9 @@ updateState aave = State.updateState (Core.aaveInstance aave)
9794

9895
makeReserveHandle :: Aave -> (AssocMap.Map AssetClass Reserve -> AaveRedeemer) -> StateHandle AaveScript (AssocMap.Map AssetClass Reserve)
9996
makeReserveHandle aave toRedeemer =
100-
let stateToken = reserveStateToken aave in
10197
StateHandle {
102-
stateToken = stateToken,
103-
toDatum = Core.ReservesDatum stateToken,
98+
stateToken = reserveStateToken aave,
99+
toDatum = Core.ReservesDatum (getAaveState aave),
104100
toRedeemer = toRedeemer
105101
}
106102

@@ -124,10 +120,9 @@ roundtripReserves aave redeemer = do
124120

125121
makeUserHandle :: Aave -> (AssocMap.Map UserConfigId UserConfig -> AaveRedeemer) -> StateHandle AaveScript (AssocMap.Map UserConfigId UserConfig)
126122
makeUserHandle aave toRedeemer =
127-
let stateToken = userStateToken aave in
128123
StateHandle {
129-
stateToken = stateToken,
130-
toDatum = Core.UserConfigsDatum stateToken,
124+
stateToken = userStateToken aave,
125+
toDatum = Core.UserConfigsDatum (getAaveState aave),
131126
toRedeemer = toRedeemer
132127
}
133128

0 commit comments

Comments
 (0)