Merge pull request #140 from mlabs-haskell/76-Lendex.QueryInsolventAc…

…counts

Closing #76 - Lendx.QueryInsolventAccounts

mlabs/mlabs-plutus-use-cases.cabal

@@ -24,6 +24,7 @@ common common-imports
     , plutus-ledger
     , plutus-tx
     , plutus-ledger-api
+    , plutus-chain-index
     , plutus-tx-plugin
     , plutus-pab
     , plutus-use-cases

mlabs/src/Mlabs/Control/Monad/State.hs

@@ -11,7 +11,6 @@ module Mlabs.Control.Monad.State (
 ) where
 
 import PlutusTx.Prelude
-import Prelude (String)
 
 import Control.Monad.Except (MonadError (..))
 import Control.Monad.State.Strict (MonadState (..), StateT (..), gets)

mlabs/src/Mlabs/Lending/Contract/Api.hs

@@ -31,6 +31,7 @@ module Mlabs.Lending.Contract.Api (
   QueryAllLendexes (..),
   QuerySupportedCurrencies (..),
   QueryCurrentBalance (..),
+  QueryInsolventAccounts (..),
 
   -- ** Price oracle actions
   SetAssetPrice (..),
@@ -172,6 +173,10 @@ newtype QueryCurrentBalance = QueryCurrentBalance ()
   deriving stock (Hask.Show, Generic)
   deriving newtype (FromJSON, ToJSON, ToSchema)
 
+newtype QueryInsolventAccounts = QueryInsolventAccounts ()
+  deriving stock (Hask.Show, Generic)
+  deriving newtype (FromJSON, ToJSON, ToSchema)
+
 -- price oracle actions
 
 -- | Updates for the prices of the currencies on the markets
@@ -208,6 +213,7 @@ type QuerySchema =
   Call QueryAllLendexes
     .\/ Call QuerySupportedCurrencies
     .\/ Call QueryCurrentBalance
+    .\/ Call QueryInsolventAccounts
 
 ----------------------------------------------------------
 -- proxy types for ToSchema instance
@@ -268,6 +274,7 @@ instance IsGovernAct AddReserve where toGovernAct (AddReserve cfg) = Types.AddRe
 -- query acts
 
 instance IsQueryAct QueryCurrentBalance where toQueryAct (QueryCurrentBalance ()) = Types.QueryCurrentBalanceAct ()
+instance IsQueryAct QueryInsolventAccounts where toQueryAct (QueryInsolventAccounts ()) = Types.QueryInsolventAccountsAct ()
 
 -- endpoint names
 
@@ -312,3 +319,6 @@ instance IsEndpoint QuerySupportedCurrencies where
 
 instance IsEndpoint QueryCurrentBalance where
   type EndpointSymbol QueryCurrentBalance = "query-current-balance"
+
+instance IsEndpoint QueryInsolventAccounts where
+  type EndpointSymbol QueryInsolventAccounts = "query-insolvent-accounts"

mlabs/src/Mlabs/Lending/Contract/Emulator/Client.hs

@@ -36,7 +36,7 @@ callUserAct lid wal act = do
     Types.AddCollateralAct {..} -> callEndpoint' hdl $ Api.AddCollateral add'asset add'amount
     Types.RemoveCollateralAct {..} -> callEndpoint' hdl $ Api.RemoveCollateral remove'asset remove'amount
     Types.WithdrawAct {..} -> callEndpoint' hdl $ Api.Withdraw act'amount act'asset
-    Types.FlashLoanAct -> pure ()
+    Types.FlashLoanAct -> pure () -- todo
     Types.LiquidationCallAct {..} ->
       case act'debt of
         Types.BadBorrow (Types.UserId pkh) asset -> callEndpoint' hdl $ Api.LiquidationCall act'collateral pkh asset act'debtToCover act'receiveAToken
@@ -48,6 +48,7 @@ callQueryAct lid wal act = do
   hdl <- activateContractWallet wal (queryEndpoints lid)
   void $ case act of
     Types.QueryCurrentBalanceAct () -> callEndpoint' hdl $ Api.QueryCurrentBalance ()
+    Types.QueryInsolventAccountsAct () -> callEndpoint' hdl $ Api.QueryInsolventAccounts ()
 
 -- | Calls price oracle act
 callPriceAct :: Types.LendexId -> Emulator.Wallet -> Types.PriceAct -> EmulatorTrace ()

mlabs/src/Mlabs/Lending/Contract/Server.hs

@@ -19,8 +19,9 @@ import Control.Lens ((^.), (^?))
 import Control.Monad (forever, guard)
 import Control.Monad.State.Strict (runStateT)
 
+import Data.Bifunctor (second)
 import Data.List.Extra (firstJust)
-import Data.Map qualified as Map (elems)
+import Data.Map qualified as Map
 import Data.Semigroup (Last (..))
 
 import Ledger.Constraints (mintingPolicy, mustIncludeDatum, ownPubKeyHash)
@@ -42,9 +43,11 @@ import Mlabs.Lending.Contract.Forge (currencyPolicy, currencySymbol)
 import Mlabs.Lending.Contract.StateMachine qualified as StateMachine
 import Mlabs.Lending.Logic.React qualified as React
 import Mlabs.Lending.Logic.Types qualified as Types
-import Mlabs.Plutus.Contract (getEndpoint, readDatum, readDatum', selectForever)
+import Mlabs.Plutus.Contract (getEndpoint, readChainIndexTxDatum, readDatum, readDatum', selectForever)
+import Plutus.Contract.Request qualified as Request
 import Plutus.Contract.Types (Promise (..), promiseMap, selectList)
 
+import Extra (firstJust)
 import Playground.Types (PlaygroundError (input))
 import PlutusTx.Prelude
 import Prelude qualified as Hask
@@ -111,6 +114,7 @@ queryEndpoints lid =
     [ getEndpoint @Api.QueryAllLendexes $ queryAllLendexes lid
     , getEndpoint @Api.QuerySupportedCurrencies $ \_ -> querySupportedCurrencies lid
     , getEndpoint @Api.QueryCurrentBalance $ queryAction lid
+    , getEndpoint @Api.QueryInsolventAccounts $ queryAction lid
     ]
 
 -- user actions
@@ -144,7 +148,7 @@ startLendex lid (Api.StartLendex Types.StartParams {..}) =
 
 queryAction :: Api.IsQueryAct a => Types.LendexId -> a -> QueryContract ()
 queryAction lid input = do
-  (_, pool) <- findInputStateData lid :: QueryContract (Types.LendexId, Types.LendingPool)
+  (_, pool) <- findDatum lid :: QueryContract (Types.LendexId, Types.LendingPool)
   qAction pool =<< getQueryAct input
   where
     qAction :: Types.LendingPool -> Types.Act -> QueryContract ()
@@ -230,3 +234,17 @@ findInputStateData lid = do
   maybe err pure $ firstJust readDatum' txOuts
   where
     err = Contract.throwError $ StateMachine.toLendexError "Can not find Lending app instance"
+
+-- | todo: add a unique NFT to distinguish between utxos / review logic.
+findDatum :: FromData d => Types.LendexId -> Contract.Contract w s StateMachine.LendexError (Types.LendexId, d)
+findDatum lid = do
+  txOuts <- filterTxOuts . Map.toList <$> Request.utxosTxOutTxAt (StateMachine.lendexAddress lid)
+  case txOuts of
+    [(_, [x])] -> maybe err return $ (lid,) <$> x -- only passes if there is only 1 datum instance.
+    _ -> err
+  where
+    err = Contract.throwError . StateMachine.toLendexError $ "Cannot establish correct Lending app instance."
+    filterTxOuts = filter ((== 1) . length . filter isNotNothing . snd) . fmap (second $ readChainIndexTxDatum . snd)
+    isNotNothing = \case
+      Nothing -> False
+      Just _ -> True

mlabs/src/Mlabs/Lending/Logic/React.hs

@@ -28,14 +28,16 @@ import Mlabs.Lending.Logic.Types (
   BadBorrow (BadBorrow, badBorrow'userId),
   CoinCfg (coinCfg'aToken, coinCfg'coin, coinCfg'interestModel, coinCfg'liquidationBonus, coinCfg'rate),
   CoinRate (CoinRate, coinRate'lastUpdateTime),
+  -- UserAct(act'rate, act'portion, act'useAsCollateral, act'asset,
+  --         act'amount, act'receiveAToken, act'debtToCover, act'debt,
+  --         act'collateral),
+
+  InsolventAccount (ia'ic),
   InterestModel (im'optimalUtilisation, im'slope1, im'slope2),
   LendingPool (lp'coinMap, lp'healthReport, lp'reserves, lp'users),
   Reserve (reserve'rate, reserve'wallet),
   User (user'health, user'lastUpdateTime, user'wallets),
   UserAct (..),
-  -- UserAct(act'rate, act'portion, act'useAsCollateral, act'asset,
-  --         act'amount, act'receiveAToken, act'debtToCover, act'debt,
-  --         act'collateral),
   UserId (Self),
   Wallet (wallet'borrow, wallet'collateral, wallet'deposit),
   adaCoin,
@@ -44,6 +46,9 @@ import Mlabs.Lending.Logic.Types (
 import Mlabs.Lending.Logic.Types qualified as Types
 import PlutusTx.Ratio qualified as R
 
+-- import qualified Control.Monad.RWS.Strict as State
+-- import PlutusCore.Name (isEmpty)
+
 {-# INLINEABLE qReact #-}
 
 -- | React to query actions by using the State Machine functions.
@@ -55,13 +60,14 @@ qReact input = do
   where
     queryAct uid time = \case
       Types.QueryCurrentBalanceAct () -> queryCurrentBalance uid time
+      Types.QueryInsolventAccountsAct () -> queryInsolventAccounts uid time
 
     ---------------------------------------------------------------------------------------------------------
     -- Current Balance Query
     queryCurrentBalance :: Types.UserId -> Integer -> State.St (Maybe (Last Types.QueryRes))
     queryCurrentBalance uid _cTime = do
       user <- State.getUser uid
-      tWallet <- State.getWallet' uid
+      tWallet <- State.getAllWallets uid
       tDeposit <- State.getTotalDeposit user
       tCollateral <- State.getTotalCollateral user
       tBorrow <- State.getTotalBorrow user
@@ -76,6 +82,32 @@ qReact input = do
           , ub'funds = tWallet
           }
 
+    ---------------------------------------------------------------------------------------------------------
+    -- Insolvent Accounts Query
+    -- Returns a list of users where the health of a coin is under 1, together
+    -- with the health of the coin. Only admins can use.
+    queryInsolventAccounts :: Types.UserId -> Integer -> State.St (Maybe (Last Types.QueryRes))
+    queryInsolventAccounts uid _cTime = do
+      State.isAdmin uid -- check user is admin
+      allUsersIds :: [UserId] <- M.keys <$> State.getAllUsers
+      allUsers :: [User] <- M.elems <$> State.getAllUsers
+      userWCoins :: [(UserId, (User, [Types.Coin]))] <-
+        fmap (zip allUsersIds . zip allUsers) $
+          sequence $ flip State.getsAllWallets M.keys <$> allUsersIds
+      insolventUsers :: [(UserId, [(Types.Coin, Rational)])] <- sequence $ fmap aux userWCoins
+      let onlyInsolventUsers = filter (not . null . snd) insolventUsers -- Remove the users with no insolvent coins.
+      pure . wrap $ uncurry Types.InsolventAccount <$> onlyInsolventUsers
+      where
+        aux :: (UserId, (User, [Types.Coin])) -> State.St (UserId, [(Types.Coin, Rational)])
+        aux = \(uId, (user, coins)) -> do
+          y <- sequence $ flip State.getCurrentHealthCheck user <$> coins
+          let coins' = fst <$> filter snd (zip coins y)
+          y' <- sequence $ flip State.getCurrentHealth user <$> coins'
+          let coins'' = zip coins' y'
+          pure $ (,) uId coins''
+
+        wrap = Just . Last . Types.QueryResInsolventAccounts
+
 {-# INLINEABLE react #-}
 
 {- | State transitions for lending pool.

mlabs/src/Mlabs/Lending/Logic/State.hs

@@ -23,11 +23,14 @@ module Mlabs.Lending.Logic.State (
   initReserve,
   guardError,
   getWallet,
-  getWallet',
+  getAllWallets,
   getsWallet,
-  getsWallet',
+  getsAllWallets,
   getUser,
   getsUser,
+  getAllUsers,
+  getsAllUsers,
+  getUsers,
   getReserve,
   getsReserve,
   toAda,
@@ -41,7 +44,9 @@ module Mlabs.Lending.Logic.State (
   getLiquidationThreshold,
   getLiquidationBonus,
   getHealth,
+  getCurrentHealthCheck,
   getHealthCheck,
+  getCurrentHealth,
   modifyUsers,
   modifyReserve,
   modifyReserveWallet,
@@ -96,6 +101,7 @@ import Mlabs.Lending.Logic.Types (
  )
 import Mlabs.Lending.Logic.Types qualified as Types
 import PlutusTx.Ratio qualified as R
+import System.Posix.Types qualified as Types
 
 -- | Type for errors
 type Error = BuiltinByteString
@@ -166,17 +172,23 @@ getWallet uid coin =
   getsUser uid (fromMaybe defaultWallet . M.lookup coin . user'wallets)
 
 -- | Get all user internal wallets.
-{-# INLINEABLE getsWallet' #-}
-getsWallet' :: Types.UserId -> (Map Types.Coin Wallet -> a) -> St a
-getsWallet' uid f =
-  f <$> getWallet' uid
+{-# INLINEABLE getsAllWallets #-}
+getsAllWallets :: Types.UserId -> (Map Types.Coin Wallet -> a) -> St a
+getsAllWallets uid f =
+  f <$> getAllWallets uid
 
 -- | Get all user internal wallets.
-{-# INLINEABLE getWallet' #-}
-getWallet' :: Types.UserId -> St (Map Types.Coin Wallet)
-getWallet' uid =
+{-# INLINEABLE getAllWallets #-}
+getAllWallets :: Types.UserId -> St (Map Types.Coin Wallet)
+getAllWallets uid =
   getsUser uid user'wallets
 
+{-# INLINEABLE getUsers #-}
+
+-- | Get a list of all the users.
+getUsers :: St [Types.UserId]
+getUsers = M.keys <$> getAllUsers
+
 {-# INLINEABLE getsUser #-}
 
 -- | Get user info in the lending app by user id and apply extractor function to it.
@@ -189,6 +201,18 @@ getsUser uid f = fmap f $ getUser uid
 getUser :: Types.UserId -> St User
 getUser uid = gets (fromMaybe defaultUser . M.lookup uid . lp'users)
 
+{-# INLINEABLE getAllUsers #-}
+
+-- | Get Map of all users.
+getAllUsers :: St (Map Types.UserId User)
+getAllUsers = gets lp'users
+
+{-# INLINEABLE getsAllUsers #-}
+
+-- | Gets all users given predicate.
+getsAllUsers :: (User -> Bool) -> St (Map Types.UserId User)
+getsAllUsers f = gets (M.filter f . lp'users)
+
 {-# INLINEABLE getsReserve #-}
 
 -- | Read reserve for a given asset and apply extractor function to it.
@@ -277,11 +301,17 @@ getTotalDeposit = walletTotal wallet'deposit
 
 {-# INLINEABLE getHealthCheck #-}
 
--- | Check that user has enough health for the given asset.
+-- | Check if the user has enough health for the given asset.
 getHealthCheck :: Integer -> Types.Coin -> User -> St Bool
 getHealthCheck addToBorrow coin user =
   fmap (> R.fromInteger 1) $ getHealth addToBorrow coin user
 
+{-# INLINEABLE getCurrentHealthCheck #-}
+
+-- | Check if the user has currently enough health for the given asset.
+getCurrentHealthCheck :: Types.Coin -> User -> St Bool
+getCurrentHealthCheck = getHealthCheck 0
+
 {-# INLINEABLE getHealth #-}
 
 -- | Check borrowing health for the user by given currency
@@ -292,6 +322,12 @@ getHealth addToBorrow coin user = do
   liq <- getLiquidationThreshold coin
   pure $ R.fromInteger col N.* liq N.* R.recip (R.fromInteger bor)
 
+{-# INLINEABLE getCurrentHealth #-}
+
+-- | Check immediate borrowing health for the user by given currency
+getCurrentHealth :: Types.Coin -> User -> St Rational
+getCurrentHealth = getHealth 0
+
 {-# INLINEABLE getLiquidationThreshold #-}
 
 -- | Reads liquidation threshold for a give asset.
@@ -403,7 +439,7 @@ getCumulativeBalance uid asset = do
 {-# INLINEABLE getWalletCumulativeBalance #-}
 getWalletCumulativeBalance :: Types.UserId -> St (Map Types.Coin Rational)
 getWalletCumulativeBalance uid = do
-  wallet <- getsWallet' uid M.toList :: St [(Types.Coin, Wallet)]
+  wallet <- getsAllWallets uid M.toList :: St [(Types.Coin, Wallet)]
   coins <- return $ fst <$> wallet :: St [Types.Coin]
   ni <- mapM getNormalisedIncome coins
   return . M.fromList $ zip coins ni

mlabs/src/Mlabs/Lending/Logic/Types.hs

@@ -52,6 +52,7 @@ module Mlabs.Lending.Logic.Types (
   QueryRes (..),
   SupportedCurrency (..),
   UserBalance (..),
+  InsolventAccount (..),
 ) where
 
 import PlutusTx.Prelude hiding ((%))
@@ -377,9 +378,11 @@ data UserAct
   deriving anyclass (FromJSON, ToJSON)
 
 -- | Query Actions.
-newtype QueryAct
+data QueryAct
   = -- | Query current balance
     QueryCurrentBalanceAct ()
+  | -- |  Query insolvent accounts
+    QueryInsolventAccountsAct ()
   deriving stock (Hask.Show, Generic, Hask.Eq)
   deriving anyclass (FromJSON, ToJSON)
 
@@ -444,21 +447,19 @@ data UserBalance = UserBalance
   , -- | User Funds
     ub'funds :: Map Coin Wallet
   }
+  deriving (Eq)
   deriving stock (Hask.Show, Generic, Hask.Eq)
   deriving anyclass (FromJSON, ToJSON)
 
--- data Funds = Funds
---   { -- | Coin
---     funds'coin :: Coin
---   , -- | Deposit Balance
---     funds'deposit :: Integer
---   , -- | Collateral Balance
---     funds'collateral :: Integer
---   , -- | Borrow Balance
---     funds'borrow :: Integer
---   }
---   deriving stock (Hask.Show, Generic, Hask.Eq)
---   deriving anyclass (FromJSON, ToJSON)
+data InsolventAccount = InsolventAccount
+  { -- | User Id
+    ia'id :: !UserId
+  , -- | Insolvent Currencies, with their Current health.
+    ia'ic :: [(Coin, Rational)]
+  }
+  deriving (Eq)
+  deriving stock (Hask.Show, Generic, Hask.Eq)
+  deriving anyclass (FromJSON, ToJSON)
 
 -- If another query is added, extend this data type
 
@@ -467,6 +468,7 @@ data QueryRes
   = QueryResAllLendexes [(Address, LendingPool)]
   | QueryResSupportedCurrencies {getSupported :: [SupportedCurrency]}
   | QueryResCurrentBalance UserBalance
+  | QueryResInsolventAccounts [InsolventAccount]
   deriving (Eq)
   deriving stock (Hask.Show, Generic, Hask.Eq)
   deriving anyclass (FromJSON, ToJSON)