Merge pull request #53 from input-output-hk/MetaLamp/lending-pool/use…

…-type-synonyms Use type synonyms
input-output-hk · Jul 2, 2021 · bf474c7 · bf474c7
2 parents 5057326 + 5af8ecb
commit bf474c7
Show file tree

Hide file tree

Showing 7 changed files with 51 additions and 48 deletions.
diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/State.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OffChain/State.hs
@@ -39,7 +39,8 @@ import           Plutus.Contracts.LendingPool.OnChain.Core (Aave (..),
                                                             AaveRedeemer (..),
                                                             AaveScript,
                                                             Reserve (..),
-                                                            UserConfig (..))
+                                                            UserConfig (..),
+                                                            UserConfigId)
 import qualified Plutus.Contracts.LendingPool.OnChain.Core as Core
 import qualified Plutus.Contracts.Service.FungibleToken    as FungibleToken
 import           Plutus.V1.Ledger.Ada                      (adaValueOf,
@@ -75,10 +76,10 @@ findAaveReserve aave reserveId = do
     reserves <- ovValue <$> findAaveReserves aave
     maybe (throwError "Reserve not found") pure $ AssocMap.lookup reserveId reserves
 
-findAaveUserConfigs :: HasBlockchainActions s => Aave -> Contract w s Text (OutputValue (AssocMap.Map (AssetClass, PubKeyHash) UserConfig))
+findAaveUserConfigs :: HasBlockchainActions s => Aave -> Contract w s Text (OutputValue (AssocMap.Map UserConfigId UserConfig))
 findAaveUserConfigs aave = findOutputBy aave (userStateToken aave) (^? Core._UserConfigsDatum . _2)
 
-findAaveUserConfig :: HasBlockchainActions s => Aave -> (AssetClass, PubKeyHash) -> Contract w s Text UserConfig
+findAaveUserConfig :: HasBlockchainActions s => Aave -> UserConfigId -> Contract w s Text UserConfig
 findAaveUserConfig aave userConfigId = do
     configs <- ovValue <$> findAaveUserConfigs aave
     maybe (throwError "UserConfig not found") pure $ AssocMap.lookup userConfigId configs
@@ -121,7 +122,7 @@ roundtripReserves aave redeemer = do
     reservesOutput <- findAaveReserves aave
     fst <$> updateReserves aave redeemer reservesOutput
 
-makeUserHandle :: Aave -> (AssocMap.Map (AssetClass, PubKeyHash) UserConfig -> AaveRedeemer) -> StateHandle AaveScript (AssocMap.Map (AssetClass, PubKeyHash) UserConfig)
+makeUserHandle :: Aave -> (AssocMap.Map UserConfigId UserConfig -> AaveRedeemer) -> StateHandle AaveScript (AssocMap.Map UserConfigId UserConfig)
 makeUserHandle aave toRedeemer =
     let stateToken = userStateToken aave in
     StateHandle {
@@ -130,20 +131,20 @@ makeUserHandle aave toRedeemer =
         toRedeemer = toRedeemer
     }
 
-putUserConfigs :: (HasBlockchainActions s) => Aave -> AaveRedeemer -> AssocMap.Map (AssetClass, PubKeyHash) UserConfig -> Contract w s Text (TxUtils.TxPair AaveScript)
+putUserConfigs :: (HasBlockchainActions s) => Aave -> AaveRedeemer -> AssocMap.Map UserConfigId UserConfig -> Contract w s Text (TxUtils.TxPair AaveScript)
 putUserConfigs aave redeemer = putState aave $ makeUserHandle aave (const redeemer)
 
-updateUserConfigs :: (HasBlockchainActions s) => Aave -> AaveRedeemer -> OutputValue (AssocMap.Map (AssetClass, PubKeyHash) UserConfig) -> Contract w s Text (TxUtils.TxPair AaveScript, AssocMap.Map (AssetClass, PubKeyHash) UserConfig)
+updateUserConfigs :: (HasBlockchainActions s) => Aave -> AaveRedeemer -> OutputValue (AssocMap.Map UserConfigId UserConfig) -> Contract w s Text (TxUtils.TxPair AaveScript, AssocMap.Map UserConfigId UserConfig)
 updateUserConfigs aave redeemer = updateState aave $ makeUserHandle aave (const redeemer)
 
-addUserConfig :: (HasBlockchainActions s) => Aave -> AaveRedeemer -> (AssetClass, PubKeyHash) -> UserConfig -> Contract w s Text (TxUtils.TxPair AaveScript, AssocMap.Map (AssetClass, PubKeyHash) UserConfig)
+addUserConfig :: (HasBlockchainActions s) => Aave -> AaveRedeemer -> UserConfigId -> UserConfig -> Contract w s Text (TxUtils.TxPair AaveScript, AssocMap.Map UserConfigId UserConfig)
 addUserConfig aave redeemer userConfigId userConfig = do
     configsOutput <- findAaveUserConfigs aave
     _ <- maybe (pure ()) (const $ throwError "Add user config failed: config exists") $
         AssocMap.lookup userConfigId (ovValue configsOutput)
     updateUserConfigs aave redeemer $ Prelude.fmap (AssocMap.insert userConfigId userConfig) configsOutput
 
-updateUserConfig :: (HasBlockchainActions s) => Aave -> AaveRedeemer -> (AssetClass, PubKeyHash) -> UserConfig -> Contract w s Text (TxUtils.TxPair AaveScript, AssocMap.Map (AssetClass, PubKeyHash) UserConfig)
+updateUserConfig :: (HasBlockchainActions s) => Aave -> AaveRedeemer -> UserConfigId -> UserConfig -> Contract w s Text (TxUtils.TxPair AaveScript, AssocMap.Map UserConfigId UserConfig)
 updateUserConfig aave redeemer userConfigId userConfig = do
     configsOutput <- findAaveUserConfigs aave
     _ <- maybe (throwError "Update failed: user config not found") pure $

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
@@ -39,8 +39,10 @@ import           Playground.Contract
 import           Plutus.Contract                                  hiding (when)
 import           Plutus.Contracts.LendingPool.OnChain.Core.Script (AaveDatum (..),
                                                                    AaveRedeemer (..),
+                                                                   Oracles,
                                                                    Reserve (..),
-                                                                   UserConfig (..))
+                                                                   UserConfig (..),
+                                                                   UserConfigId)
 import qualified Plutus.Contracts.Service.Oracle                  as Oracle
 import           Plutus.V1.Ledger.Value
 import qualified PlutusTx
@@ -52,7 +54,7 @@ import           Prelude                                          (Semigroup (..
 import qualified Prelude
 
 {-# INLINABLE pickUserConfigs #-}
-pickUserConfigs :: AaveDatum -> Maybe (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig)
+pickUserConfigs :: AaveDatum -> Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig)
 pickUserConfigs (UserConfigsDatum stateToken configs) = Just (stateToken, configs)
 pickUserConfigs _ = Nothing
 
@@ -69,14 +71,14 @@ pickUserCollateralFunds _ = Nothing
 {-# INLINABLE totalDebtAndCollateralInLovelace #-}
 totalDebtAndCollateralInLovelace ::
      PubKeyHash
-  -> AssocMap.Map AssetClass Integer
-  -> AssocMap.Map (AssetClass, PubKeyHash) UserConfig
+  -> Oracles
+  -> AssocMap.Map UserConfigId UserConfig
   -> Maybe UserConfig
 totalDebtAndCollateralInLovelace actor oracles userConfigs =
   foldrM addCollateral (UserConfig 0 0) $ AssocMap.toList userConfigs
   where
     addCollateral ::
-         ((AssetClass, PubKeyHash), UserConfig)
+         (UserConfigId, UserConfig)
       -> UserConfig
       -> Maybe UserConfig
     addCollateral ((asset, user), userConfig) currentTotal
@@ -91,8 +93,8 @@ totalDebtAndCollateralInLovelace actor oracles userConfigs =
 {-# INLINABLE doesCollateralCoverDebt #-}
 doesCollateralCoverDebt ::
      PubKeyHash
-  -> AssocMap.Map AssetClass Integer
-  -> AssocMap.Map (AssetClass, PubKeyHash) UserConfig
+  -> Oracles
+  -> AssocMap.Map UserConfigId UserConfig
   -> Bool
 doesCollateralCoverDebt actor oracles userConfigs = maybe False (\UserConfig{..} -> ucDebt <= ucCollateralizedInvestment) $
   totalDebtAndCollateralInLovelace actor oracles userConfigs
@@ -129,7 +131,7 @@ checkNegativeFundsTransformation ctx asset actor = isValidFundsChange
 checkNegativeReservesTransformation :: AssetClass
   -> AssocMap.Map AssetClass Reserve
   -> ScriptContext
-  -> (AssetClass, PubKeyHash)
+  -> UserConfigId
   -> Bool
 checkNegativeReservesTransformation stateToken reserves ctx (reserveId, _) =
       maybe False checkreserves reservesOutputDatum
@@ -164,7 +166,7 @@ checkNegativeReservesTransformation stateToken reserves ctx (reserveId, _) =
 checkPositiveReservesTransformation :: AssetClass
   -> AssocMap.Map AssetClass Reserve
   -> ScriptContext
-  -> (AssetClass, PubKeyHash)
+  -> UserConfigId
   -> Bool
 checkPositiveReservesTransformation stateToken reserves ctx (reserveId, _) = maybe False checkreserves reservesOutputDatum
   where

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
@@ -90,29 +90,30 @@ PlutusTx.unstableMakeIsData ''UserConfig
 PlutusTx.makeLift ''UserConfig
 Lens.makeClassy_ ''UserConfig
 
+type UserConfigId = (AssetClass, PubKeyHash)
+
 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)]
+  | DepositRedeemer UserConfigId
+  | WithdrawRedeemer UserConfigId
+  | BorrowRedeemer UserConfigId [(CurrencySymbol, PubKeyHash, Integer, AssetClass)]
+  | RepayRedeemer UserConfigId
+  | ProvideCollateralRedeemer UserConfigId
+  | RevokeCollateralRedeemer UserConfigId 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
+  | UserConfigsDatum AssetClass (AssocMap.Map UserConfigId UserConfig) -- State token and UserConfigId -> user config map
   | UserCollateralFundsDatum PubKeyHash AssetClass -- User pub key and aToken asset type
   deriving stock (Show)
 

diff --git a/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Validator.hs b/MetaLamp/lending-pool/src/Plutus/Contracts/LendingPool/OnChain/Core/Validator.hs
@@ -55,7 +55,8 @@ import           Plutus.Contracts.LendingPool.OnChain.Core.Script (AaveDatum (..
                                                                    AaveRedeemer (..),
                                                                    AaveScript,
                                                                    Reserve (..),
-                                                                   UserConfig (..))
+                                                                   UserConfig (..),
+                                                                   UserConfigId)
 import qualified Plutus.Contracts.Service.Oracle                  as Oracle
 import           Plutus.V1.Ledger.Value
 import qualified PlutusTx
@@ -117,7 +118,7 @@ validateStart aave (LendingPoolDatum operator) ctx =
 validateStart aave _ ctx = trace "validateStart: Lending Pool Datum management is not allowed" False
 
 {-# INLINABLE validateDeposit #-}
-validateDeposit :: Aave -> AaveDatum -> ScriptContext -> (AssetClass, PubKeyHash) -> Bool
+validateDeposit :: Aave -> AaveDatum -> ScriptContext -> UserConfigId -> Bool
 validateDeposit aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId =
   traceIfFalse "validateDeposit: User Configs Datum change is not valid" isValidUserConfigsTransformation
   where
@@ -126,14 +127,14 @@ validateDeposit aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId
     userConfigsOutputDatumHash =
       findOnlyOneDatumHashByValue (assetClassValue stateToken 1) $ scriptOutputsAt scriptsHash txInfo
     userConfigsOutputDatum ::
-         Maybe (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig)
+         Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig)
     userConfigsOutputDatum =
       userConfigsOutputDatumHash >>= parseDatum txInfo >>= pickUserConfigs
 
     isValidUserConfigsTransformation :: Bool
     isValidUserConfigsTransformation =
       maybe False checkUserConfigs userConfigsOutputDatum
-    checkUserConfigs :: (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig) -> Bool
+    checkUserConfigs :: (AssetClass, AssocMap.Map UserConfigId UserConfig) -> Bool
     checkUserConfigs (newStateToken, newUserConfigs) =
       newStateToken == stateToken &&
       maybe
@@ -152,7 +153,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 -> AaveDatum -> ScriptContext -> UserConfigId -> Bool
 validateWithdraw aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId =
   -- TODO add implementation for this case
   traceIfFalse "validateWithdraw: User Configs Datum change is not valid" False
@@ -165,7 +166,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 -> AaveDatum -> ScriptContext -> UserConfigId -> [(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
   where
@@ -175,7 +176,7 @@ validateBorrow aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(
     userConfigsOutputDatumHash =
       findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs
     userConfigsOutputDatum ::
-         Maybe (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig)
+         Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig)
     userConfigsOutputDatum =
       userConfigsOutputDatumHash >>= parseDatum txInfo >>= pickUserConfigs
 
@@ -191,7 +192,7 @@ validateBorrow aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(
     isValidUserConfigsTransformation =
       maybe False checkUserConfigs userConfigsOutputDatum
     checkUserConfigs ::
-         (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig) -> Bool
+         (AssetClass, AssocMap.Map UserConfigId UserConfig) -> Bool
     checkUserConfigs (newStateToken, newUserConfigs) =
       newStateToken == stateToken && doesCollateralCoverDebt actor oracleValues newUserConfigs &&
       maybe False (checkRedeemerConfig $ AssocMap.lookup userConfigId userConfigs) (AssocMap.lookup userConfigId newUserConfigs)
@@ -211,7 +212,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 -> AaveDatum -> ScriptContext -> UserConfigId -> Bool
 validateRepay aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(reserveId, actor) =
   traceIfFalse "validateRepay: User Configs Datum change is not valid" isValidUserConfigsTransformation
   where
@@ -221,7 +222,7 @@ validateRepay aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(r
     userConfigsOutputDatumHash =
       findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs
     userConfigsOutputDatum ::
-         Maybe (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig)
+         Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig)
     userConfigsOutputDatum =
       userConfigsOutputDatumHash >>= parseDatum txInfo >>= pickUserConfigs
 
@@ -231,7 +232,7 @@ validateRepay aave (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(r
     isValidUserConfigsTransformation :: Bool
     isValidUserConfigsTransformation =
       maybe False checkUserConfigs userConfigsOutputDatum
-    checkUserConfigs :: (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig) -> Bool
+    checkUserConfigs :: (AssetClass, AssocMap.Map UserConfigId UserConfig) -> Bool
     checkUserConfigs (newStateToken, newUserConfigs) =
       newStateToken == stateToken &&
       (Just True ==
@@ -250,7 +251,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 -> AaveDatum -> ScriptContext -> UserConfigId -> Bool
 validateProvideCollateral aave  (UserConfigsDatum stateToken userConfigs) ctx userConfigId@(reserveId, actor) =
   traceIfFalse "validateProvideCollateral: User Configs Datum change is not valid" isValidUserConfigsTransformation
   where
@@ -261,7 +262,7 @@ validateProvideCollateral aave  (UserConfigsDatum stateToken userConfigs) ctx us
     userConfigsOutputDatumHash =
       findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs
     userConfigsOutputDatum ::
-         Maybe (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig)
+         Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig)
     userConfigsOutputDatum =
       userConfigsOutputDatumHash >>= parseDatum txInfo >>= pickUserConfigs
 
@@ -279,7 +280,7 @@ validateProvideCollateral aave  (UserConfigsDatum stateToken userConfigs) ctx us
     isValidUserConfigsTransformation =
       fromMaybe False $ checkUserConfigs <$> userConfigsOutputDatum <*> collateralOutputDatum
     checkUserConfigs ::
-         (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig) -> (PubKeyHash, AssetClass) -> Bool
+         (AssetClass, AssocMap.Map UserConfigId UserConfig) -> (PubKeyHash, AssetClass) -> Bool
     checkUserConfigs (newStateToken, newUserConfigs) (user, aTokenAsset) =
       newStateToken == stateToken && user == actor &&
       maybe False (checkRedeemerConfig aTokenAsset $ AssocMap.lookup userConfigId userConfigs) (AssocMap.lookup userConfigId newUserConfigs)
@@ -293,7 +294,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 -> AaveDatum -> ScriptContext -> UserConfigId -> 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
   where
@@ -304,7 +305,7 @@ validateRevokeCollateral aave  (UserConfigsDatum stateToken userConfigs) ctx use
     userConfigsOutputDatumHash =
       findOnlyOneDatumHashByValue (assetClassValue stateToken 1) scriptOutputs
     userConfigsOutputDatum ::
-         Maybe (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig)
+         Maybe (AssetClass, AssocMap.Map UserConfigId UserConfig)
     userConfigsOutputDatum =
       userConfigsOutputDatumHash >>= parseDatum txInfo >>= pickUserConfigs
 
@@ -320,7 +321,7 @@ validateRevokeCollateral aave  (UserConfigsDatum stateToken userConfigs) ctx use
     isValidUserConfigsTransformation =
       maybe False checkUserConfigs userConfigsOutputDatum
     checkUserConfigs ::
-         (AssetClass, AssocMap.Map (AssetClass, PubKeyHash) UserConfig) -> Bool
+         (AssetClass, AssocMap.Map UserConfigId UserConfig) -> Bool
     checkUserConfigs (newStateToken, newUserConfigs) =
       newStateToken == stateToken && doesCollateralCoverDebt actor oracleValues newUserConfigs &&
       fromMaybe False (checkRedeemerConfig <$> (AssocMap.lookup userConfigId userConfigs) <*> (AssocMap.lookup userConfigId newUserConfigs))