Skip to content

Commit ce23cba

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

File tree

13 files changed

+438
-354
lines changed

13 files changed

+438
-354
lines changed

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,7 @@ import qualified Plutus.Contracts.LendingPool.OnChain.Core as Aave
3838
import qualified Plutus.Contracts.Service.Oracle as Oracle
3939
import Plutus.PAB.Simulation (AaveContracts (..))
4040
import Plutus.V1.Ledger.Value (AssetClass)
41+
import Plutus.Abstract.IncentivizedAmount (IncentivizedAmount)
4142

4243
ratioBridge :: BridgePart
4344
ratioBridge = do
@@ -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: 21 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -5,18 +5,23 @@
55
module Ext.Plutus.Ledger.Contexts where
66

77
import Ledger (Address (Address),
8-
Datum (getDatum), DatumHash,
8+
Datum (..), DatumHash,
99
PubKeyHash,
1010
TxInInfo (txInInfoResolved),
1111
TxInfo (txInfoInputs),
1212
TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue),
13-
ValidatorHash, Value, findDatum)
13+
ValidatorHash, Value, findDatum, ScriptContext, scriptOutputsAt, scriptContextTxInfo, ownHashes, findDatumHash)
1414
import Plutus.V1.Ledger.Credential (Credential (PubKeyCredential, ScriptCredential))
1515
import qualified PlutusTx
1616
import PlutusTx.Prelude (Eq ((==)), Maybe (..), filter,
1717
find, fst, mapMaybe, mconcat,
1818
otherwise, snd, ($), (.), (<$>),
1919
(>>=))
20+
import Plutus.V1.Ledger.Contexts (ScriptContext)
21+
22+
{-# INLINABLE findOnlyOneDatumByValue #-}
23+
findOnlyOneDatumByValue :: PlutusTx.IsData a => ScriptContext -> Value -> Maybe a
24+
findOnlyOneDatumByValue ctx value = findOnlyOneDatumHashByValue value (getScriptOutputs ctx) >>= parseDatum (scriptContextTxInfo ctx)
2025

2126
{-# INLINABLE findOnlyOneDatumHashByValue #-}
2227
-- | Find the hash of a datum, if it is part of the script's outputs.
@@ -28,6 +33,20 @@ findOnlyOneDatumHashByValue val outs = fst <$> case filter f outs of
2833
where
2934
f (_, val') = val' == val
3035

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

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

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,48 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE DerivingStrategies #-}
5+
{-# LANGUAGE FlexibleContexts #-}
6+
{-# LANGUAGE MultiParamTypeClasses #-}
7+
{-# LANGUAGE NoImplicitPrelude #-}
8+
{-# LANGUAGE OverloadedStrings #-}
9+
{-# LANGUAGE ScopedTypeVariables #-}
10+
{-# LANGUAGE TypeFamilies #-}
11+
{-# LANGUAGE FlexibleInstances #-}
12+
{-# LANGUAGE DeriveFunctor #-}
13+
{-# LANGUAGE TemplateHaskell #-}
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 Plutus.V1.Ledger.Slot (Slot(..))
23+
import PlutusTx.Prelude
24+
import qualified Prelude
25+
import Data.Aeson(ToJSON, FromJSON)
26+
import GHC.Generics
27+
import Schema (ToSchema)
28+
import qualified PlutusTx
29+
import PlutusTx.Ratio (Ratio)
30+
import qualified Plutus.Abstract.TxUtils as TxUtils
31+
import qualified Control.Lens as Lens
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)
45+
46+
{-(worker amount (getSlot $ newSlot - oldSlot))
47+
where
48+
worker amount slot = if slot > 0 then worker (rate * amount) (slot - 1) else amount-}

‎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)