{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableSuperClasses #-}
-- some GHC bug wrongfully complains about CanGetInstantStake constraint being redundant.
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Cardano.Ledger.State.Account (
  CanGetAccounts (..),
  CanSetAccounts (..),
  EraAccounts (..),
  lookupAccountState,
  lookupAccountStateIntern,
  updateLookupAccountState,
  isAccountRegistered,
  adjustAccountState,
  lookupStakePoolDelegation,
  sumBalancesAccounts,
  sumDepositsAccounts,
  addToBalanceAccounts,
  withdrawalsThatDoNotDrainAccounts,
  drainAccounts,
  removeStakePoolDelegations,
) where

import Cardano.Ledger.BaseTypes (Mismatch (..), Network, Relation (..))
import Cardano.Ledger.Binary
import Cardano.Ledger.Coin
import Cardano.Ledger.Compactible
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Control.DeepSeq (NFData)
import Control.Exception (assert)
import Data.Aeson (ToJSON)
import Data.Bifunctor (Bifunctor (..))
import Data.Default (Default)
import Data.Foldable (foldMap')
import Data.Kind (Type)
import qualified Data.Map.Merge.Strict as Map
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.MapExtras (lookupInternMap)
import Data.Set (Set)
import Lens.Micro
import NoThunks.Class (NoThunks)

class CanGetAccounts t where
  accountsG :: SimpleGetter (t era) (Accounts era)
  default accountsG :: CanSetAccounts t => SimpleGetter (t era) (Accounts era)
  accountsG = (Accounts era -> Const r (Accounts era))
-> t era -> Const r (t era)
forall era. Lens' (t era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
  {-# INLINE accountsG #-}

class CanGetAccounts t => CanSetAccounts t where
  accountsL :: Lens' (t era) (Accounts era)

class
  ( Era era
  , Eq (Accounts era)
  , Show (Accounts era)
  , Default (Accounts era)
  , EncCBOR (Accounts era)
  , DecShareCBOR (Accounts era)
  , Share (Accounts era)
      ~ ( Interns (Credential Staking)
        , Interns (KeyHash StakePool)
        , Interns (Credential DRepRole)
        )
  , ToJSON (Accounts era)
  , NFData (Accounts era)
  , NoThunks (Accounts era)
  , Eq (AccountState era)
  , Show (AccountState era)
  , NFData (AccountState era)
  , NoThunks (AccountState era)
  ) =>
  EraAccounts era
  where
  type AccountState era = (r :: Type) | r -> era
  type Accounts era = (r :: Type) | r -> era

  -- | Add `AccountState` to `Accounts`. There are no checks whether account is already registered
  -- or not.
  addAccountState :: Credential Staking -> AccountState era -> Accounts era -> Accounts era

  accountsMapL :: Lens' (Accounts era) (Map (Credential Staking) (AccountState era))

  balanceAccountStateL :: Lens' (AccountState era) (CompactForm Coin)

  depositAccountStateL :: Lens' (AccountState era) (CompactForm Coin)

  stakePoolDelegationAccountStateL :: Lens' (AccountState era) (Maybe (KeyHash StakePool))

  -- | Remove the account from the state. Note that it is not capable of affecting state for DReps
  -- and StakePools, those have to be handled separately.
  --
  -- There is no counterpart for registering an account, because different eras require different
  -- information. However for testing purposed there is
  -- `Test.Cardano.Ledger.Era.registerTestAccount` that can be used for all eras.
  unregisterAccount ::
    -- | Credential to unregister
    Credential Staking ->
    -- | `Accounts` to remove the account state from
    Accounts era ->
    -- | Returns `Just` whenever account was registered and `Nothing` otherwise. Produced `Accounts`
    -- will have the account state removed, if it was present there to begin with.
    (Maybe (AccountState era), Accounts era)

sumBalancesAccounts :: EraAccounts era => Accounts era -> Coin
sumBalancesAccounts :: forall era. EraAccounts era => Accounts era -> Coin
sumBalancesAccounts Accounts era
accounts =
  CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$ (AccountState era -> CompactForm Coin)
-> Map (Credential Staking) (AccountState era) -> CompactForm Coin
forall m a. Monoid m => (a -> m) -> Map (Credential Staking) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL) (Map (Credential Staking) (AccountState era) -> CompactForm Coin)
-> Map (Credential Staking) (AccountState era) -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ Accounts era
accounts Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL

sumDepositsAccounts :: EraAccounts era => Accounts era -> Coin
sumDepositsAccounts :: forall era. EraAccounts era => Accounts era -> Coin
sumDepositsAccounts Accounts era
accounts =
  CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$ (AccountState era -> CompactForm Coin)
-> Map (Credential Staking) (AccountState era) -> CompactForm Coin
forall m a. Monoid m => (a -> m) -> Map (Credential Staking) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
depositAccountStateL) (Map (Credential Staking) (AccountState era) -> CompactForm Coin)
-> Map (Credential Staking) (AccountState era) -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ Accounts era
accounts Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL

-- | Top up balance in accounts
--
-- /Warning/ - it is an error to try to increase a balance of an account that is not present in
-- `Accounts`
addToBalanceAccounts ::
  EraAccounts era =>
  -- | Map containing amounts that the balance in the account should be increased by. It is
  -- important to ensure that all of the credentials in this Map are actually registered.
  Map (Credential Staking) (CompactForm Coin) ->
  -- | Accounts that will have their balance increased.
  Accounts era ->
  Accounts era
addToBalanceAccounts :: forall era.
EraAccounts era =>
Map (Credential Staking) (CompactForm Coin)
-> Accounts era -> Accounts era
addToBalanceAccounts Map (Credential Staking) (CompactForm Coin)
addBalanceMap Accounts era
accounts =
  Accounts era
accounts
    Accounts era -> (Accounts era -> Accounts era) -> Accounts era
forall a b. a -> (a -> b) -> b
& (Map (Credential Staking) (AccountState era)
 -> Identity (Map (Credential Staking) (AccountState era)))
-> Accounts era -> Identity (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL
      ((Map (Credential Staking) (AccountState era)
  -> Identity (Map (Credential Staking) (AccountState era)))
 -> Accounts era -> Identity (Accounts era))
-> (Map (Credential Staking) (AccountState era)
    -> Map (Credential Staking) (AccountState era))
-> Accounts era
-> Accounts era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ SimpleWhenMissing
  (Credential Staking) (CompactForm Coin) (AccountState era)
-> SimpleWhenMissing
     (Credential Staking) (AccountState era) (AccountState era)
-> SimpleWhenMatched
     (Credential Staking)
     (CompactForm Coin)
     (AccountState era)
     (AccountState era)
-> Map (Credential Staking) (CompactForm Coin)
-> Map (Credential Staking) (AccountState era)
-> Map (Credential Staking) (AccountState era)
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
        -- We have an assert here, since this should never be the case that we try to add to a
        -- balance of a non-registered account
        ((Credential Staking
 -> CompactForm Coin -> Maybe (AccountState era))
-> SimpleWhenMissing
     (Credential Staking) (CompactForm Coin) (AccountState era)
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> Maybe y) -> WhenMissing f k x y
Map.mapMaybeMissing (\Credential Staking
_ CompactForm Coin
_ -> Bool -> Maybe (AccountState era) -> Maybe (AccountState era)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False Maybe (AccountState era)
forall a. Maybe a
Nothing))
        SimpleWhenMissing
  (Credential Staking) (AccountState era) (AccountState era)
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
Map.preserveMissing
        ((Credential Staking
 -> CompactForm Coin -> AccountState era -> AccountState era)
-> SimpleWhenMatched
     (Credential Staking)
     (CompactForm Coin)
     (AccountState era)
     (AccountState era)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched (\Credential Staking
_ CompactForm Coin
balanceToAdd -> (CompactForm Coin -> Identity (CompactForm Coin))
-> AccountState era -> Identity (AccountState era)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL ((CompactForm Coin -> Identity (CompactForm Coin))
 -> AccountState era -> Identity (AccountState era))
-> CompactForm Coin -> AccountState era -> AccountState era
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ CompactForm Coin
balanceToAdd))
        Map (Credential Staking) (CompactForm Coin)
addBalanceMap

-- | Lookup an account state by its credential. Returns Nothing if such account is not registrered
lookupAccountState ::
  EraAccounts era => Credential Staking -> Accounts era -> Maybe (AccountState era)
lookupAccountState :: forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Maybe (AccountState era)
lookupAccountState Credential Staking
cred Accounts era
accounts = Credential Staking
-> Map (Credential Staking) (AccountState era)
-> Maybe (AccountState era)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential Staking
cred (Accounts era
accounts Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL)

lookupAccountStateIntern ::
  EraAccounts era =>
  Credential Staking -> Accounts era -> Maybe (Credential Staking, AccountState era)
lookupAccountStateIntern :: forall era.
EraAccounts era =>
Credential Staking
-> Accounts era -> Maybe (Credential Staking, AccountState era)
lookupAccountStateIntern Credential Staking
cred Accounts era
accounts =
  Credential Staking
-> Map (Credential Staking) (AccountState era)
-> Maybe (Credential Staking, AccountState era)
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
lookupInternMap Credential Staking
cred (Accounts era
accounts Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL)

-- | Update account state. Returns Nothing if the value is not present and modified value otherwise
updateLookupAccountState ::
  EraAccounts era =>
  (AccountState era -> AccountState era) ->
  Credential Staking ->
  Accounts era ->
  (Maybe (AccountState era), Accounts era)
updateLookupAccountState :: forall era.
EraAccounts era =>
(AccountState era -> AccountState era)
-> Credential Staking
-> Accounts era
-> (Maybe (AccountState era), Accounts era)
updateLookupAccountState AccountState era -> AccountState era
f Credential Staking
cred Accounts era
accounts =
  case (Credential Staking
 -> AccountState era -> Maybe (AccountState era))
-> Credential Staking
-> Map (Credential Staking) (AccountState era)
-> (Maybe (AccountState era),
    Map (Credential Staking) (AccountState era))
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\Credential Staking
_ -> AccountState era -> Maybe (AccountState era)
forall a. a -> Maybe a
Just (AccountState era -> Maybe (AccountState era))
-> (AccountState era -> AccountState era)
-> AccountState era
-> Maybe (AccountState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccountState era -> AccountState era
f) Credential Staking
cred (Accounts era
accounts Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL) of
    (Maybe (AccountState era)
res, Map (Credential Staking) (AccountState era)
accountsMap) -> (Maybe (AccountState era)
res, Accounts era
accounts Accounts era -> (Accounts era -> Accounts era) -> Accounts era
forall a b. a -> (a -> b) -> b
& (Map (Credential Staking) (AccountState era)
 -> Identity (Map (Credential Staking) (AccountState era)))
-> Accounts era -> Identity (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL ((Map (Credential Staking) (AccountState era)
  -> Identity (Map (Credential Staking) (AccountState era)))
 -> Accounts era -> Identity (Accounts era))
-> Map (Credential Staking) (AccountState era)
-> Accounts era
-> Accounts era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (Credential Staking) (AccountState era)
accountsMap)

-- | Check whether account for this staking credential is registered
isAccountRegistered :: EraAccounts era => Credential Staking -> Accounts era -> Bool
isAccountRegistered :: forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Bool
isAccountRegistered Credential Staking
cred Accounts era
accounts = Credential Staking
-> Map (Credential Staking) (AccountState era) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Credential Staking
cred (Accounts era
accounts Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL)

adjustAccountState ::
  EraAccounts era =>
  (AccountState era -> AccountState era) -> Credential Staking -> Accounts era -> Accounts era
adjustAccountState :: forall era.
EraAccounts era =>
(AccountState era -> AccountState era)
-> Credential Staking -> Accounts era -> Accounts era
adjustAccountState AccountState era -> AccountState era
f Credential Staking
cred = (Map (Credential Staking) (AccountState era)
 -> Identity (Map (Credential Staking) (AccountState era)))
-> Accounts era -> Identity (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL ((Map (Credential Staking) (AccountState era)
  -> Identity (Map (Credential Staking) (AccountState era)))
 -> Accounts era -> Identity (Accounts era))
-> (Map (Credential Staking) (AccountState era)
    -> Map (Credential Staking) (AccountState era))
-> Accounts era
-> Accounts era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (AccountState era -> AccountState era)
-> Credential Staking
-> Map (Credential Staking) (AccountState era)
-> Map (Credential Staking) (AccountState era)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust AccountState era -> AccountState era
f Credential Staking
cred

-- | In case when account state is registered and it is delegated to a stake pool this function
-- will return that delegation.
lookupStakePoolDelegation ::
  EraAccounts era =>
  Credential Staking ->
  Accounts era ->
  Maybe (KeyHash StakePool)
lookupStakePoolDelegation :: forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Maybe (KeyHash StakePool)
lookupStakePoolDelegation Credential Staking
cred Accounts era
accounts =
  Credential Staking -> Accounts era -> Maybe (AccountState era)
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Maybe (AccountState era)
lookupAccountState Credential Staking
cred Accounts era
accounts
    Maybe (AccountState era)
-> (AccountState era -> Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (AccountState era
-> Getting
     (Maybe (KeyHash StakePool))
     (AccountState era)
     (Maybe (KeyHash StakePool))
-> Maybe (KeyHash StakePool)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (KeyHash StakePool))
  (AccountState era)
  (Maybe (KeyHash StakePool))
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash StakePool))
Lens' (AccountState era) (Maybe (KeyHash StakePool))
stakePoolDelegationAccountStateL)

-- | This function returns `Nothing` iff all of the accounts that withdrawals
-- are trying to drain are indeed registered and all of the amounts in the
-- withdrawals match the respective balances exactly. It returns a 2-tuple where
-- the `fst` is withdrawals with missing account addresses or the wrong network,
-- and `snd` is incomplete withdrawals.
--
-- NOTE: We simply `checkBadWithdrawals` to avoid allocating new variables for
-- the most likely case.
withdrawalsThatDoNotDrainAccounts ::
  EraAccounts era =>
  Withdrawals ->
  Network ->
  Accounts era ->
  -- | invalid withdrawal = that which does not have an account address or is in
  -- the wrong network.
  -- incomplete withdrawal = that which does not withdraw the exact account
  -- balance.
  Maybe (Withdrawals, Map AccountAddress (Mismatch RelEQ Coin))
withdrawalsThatDoNotDrainAccounts :: forall era.
EraAccounts era =>
Withdrawals
-> Network
-> Accounts era
-> Maybe (Withdrawals, Map AccountAddress (Mismatch RelEQ Coin))
withdrawalsThatDoNotDrainAccounts (Withdrawals Map AccountAddress Coin
withdrawals) Network
networkId Accounts era
accounts
  -- @withdrawals@ is small and @accounts@ big, better to traverse the former than the latter.
  | (AccountAddress -> Coin -> Bool -> Bool)
-> Bool -> Map AccountAddress Coin -> Bool
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey AccountAddress -> Coin -> Bool -> Bool
checkBadWithdrawals Bool
True Map AccountAddress Coin
withdrawals = Maybe (Withdrawals, Map AccountAddress (Mismatch RelEQ Coin))
forall a. Maybe a
Nothing
  | Bool
otherwise =
      (Withdrawals, Map AccountAddress (Mismatch RelEQ Coin))
-> Maybe (Withdrawals, Map AccountAddress (Mismatch RelEQ Coin))
forall a. a -> Maybe a
Just ((Withdrawals, Map AccountAddress (Mismatch RelEQ Coin))
 -> Maybe (Withdrawals, Map AccountAddress (Mismatch RelEQ Coin)))
-> (Withdrawals, Map AccountAddress (Mismatch RelEQ Coin))
-> Maybe (Withdrawals, Map AccountAddress (Mismatch RelEQ Coin))
forall a b. (a -> b) -> a -> b
$
        (Map AccountAddress Coin -> Withdrawals)
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
-> (Withdrawals, Map AccountAddress (Mismatch RelEQ Coin))
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Map AccountAddress Coin -> Withdrawals
Withdrawals ((Map AccountAddress Coin,
  Map AccountAddress (Mismatch RelEQ Coin))
 -> (Withdrawals, Map AccountAddress (Mismatch RelEQ Coin)))
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
-> (Withdrawals, Map AccountAddress (Mismatch RelEQ Coin))
forall a b. (a -> b) -> a -> b
$
          (AccountAddress
 -> Coin
 -> (Map AccountAddress Coin,
     Map AccountAddress (Mismatch RelEQ Coin))
 -> (Map AccountAddress Coin,
     Map AccountAddress (Mismatch RelEQ Coin)))
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
-> Map AccountAddress Coin
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey AccountAddress
-> Coin
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
collectBadWithdrawals (Map AccountAddress Coin
forall k a. Map k a
Map.empty, Map AccountAddress (Mismatch RelEQ Coin)
forall k a. Map k a
Map.empty) Map AccountAddress Coin
withdrawals
  where
    checkBadWithdrawals :: AccountAddress -> Coin -> Bool -> Bool
checkBadWithdrawals AccountAddress
accountAddress Coin
withdrawalAmount Bool
noBadWithdrawals =
      Bool
noBadWithdrawals Bool -> Bool -> Bool
&& AccountAddress -> Coin -> Bool
isGoodWithdrawal AccountAddress
accountAddress Coin
withdrawalAmount
    collectBadWithdrawals :: AccountAddress
-> Coin
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
collectBadWithdrawals AccountAddress
accountAddress Coin
withdrawalAmount accum :: (Map AccountAddress Coin, Map AccountAddress (Mismatch RelEQ Coin))
accum@(!Map AccountAddress Coin
_, !Map AccountAddress (Mismatch RelEQ Coin)
_) =
      case AccountAddress -> Maybe (AccountState era)
lookupAccount AccountAddress
accountAddress of
        Maybe (AccountState era)
Nothing -> (Map AccountAddress Coin -> Map AccountAddress Coin)
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (AccountAddress
-> Coin -> Map AccountAddress Coin -> Map AccountAddress Coin
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AccountAddress
accountAddress Coin
withdrawalAmount) (Map AccountAddress Coin, Map AccountAddress (Mismatch RelEQ Coin))
accum
        Just AccountState era
account
          | Coin -> AccountState era -> Bool
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraAccounts era) =>
Coin -> AccountState era -> Bool
isBalanceZero Coin
withdrawalAmount AccountState era
account -> (Map AccountAddress Coin, Map AccountAddress (Mismatch RelEQ Coin))
accum
          | Bool
otherwise ->
              (Map AccountAddress (Mismatch RelEQ Coin)
 -> Map AccountAddress (Mismatch RelEQ Coin))
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
-> (Map AccountAddress Coin,
    Map AccountAddress (Mismatch RelEQ Coin))
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second
                ( AccountAddress
-> Mismatch RelEQ Coin
-> Map AccountAddress (Mismatch RelEQ Coin)
-> Map AccountAddress (Mismatch RelEQ Coin)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AccountAddress
accountAddress (Mismatch RelEQ Coin
 -> Map AccountAddress (Mismatch RelEQ Coin)
 -> Map AccountAddress (Mismatch RelEQ Coin))
-> Mismatch RelEQ Coin
-> Map AccountAddress (Mismatch RelEQ Coin)
-> Map AccountAddress (Mismatch RelEQ Coin)
forall a b. (a -> b) -> a -> b
$
                    Coin -> Coin -> Mismatch RelEQ Coin
forall (r :: Relation) a. a -> a -> Mismatch r a
Mismatch Coin
withdrawalAmount (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$ AccountState era
account AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL)
                )
                (Map AccountAddress Coin, Map AccountAddress (Mismatch RelEQ Coin))
accum
    isGoodWithdrawal :: AccountAddress -> Coin -> Bool
isGoodWithdrawal AccountAddress
accountAddress Coin
withdrawalAmount =
      Bool
-> (AccountState era -> Bool) -> Maybe (AccountState era) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Coin -> AccountState era -> Bool
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraAccounts era) =>
Coin -> AccountState era -> Bool
isBalanceZero Coin
withdrawalAmount) (AccountAddress -> Maybe (AccountState era)
lookupAccount AccountAddress
accountAddress)
    isBalanceZero :: Coin -> AccountState era -> Bool
isBalanceZero Coin
withdrawalAmount AccountState era
accountState =
      Coin
withdrawalAmount Coin -> Coin -> Bool
forall a. Eq a => a -> a -> Bool
== CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (AccountState era
accountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL)
    lookupAccount :: AccountAddress -> Maybe (AccountState era)
lookupAccount (AccountAddress Network
aaNetworkId (AccountId Credential Staking
credential))
      | Network
aaNetworkId Network -> Network -> Bool
forall a. Eq a => a -> a -> Bool
== Network
networkId = Credential Staking -> Accounts era -> Maybe (AccountState era)
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Maybe (AccountState era)
lookupAccountState Credential Staking
credential Accounts era
accounts
      | Bool
otherwise = Maybe (AccountState era)
forall a. Maybe a
Nothing

-- | Reset balances to zero for all accounts that are specified in the supplied `Withdrawals`.
--
-- /Note/ - There are no checks that withdrawals mention only registered accounts with correct
-- `NetworkId`. Nor there are any checks that amounts in withdrawals match up the balance in the
-- corresponding accounts. Use `withdrawalsThatDoNotDrainAccounts` to verify that calling
-- `drainAccounts` is actually safe on the supplied arguments
drainAccounts ::
  EraAccounts era =>
  Withdrawals ->
  Accounts era ->
  Accounts era
drainAccounts :: forall era.
EraAccounts era =>
Withdrawals -> Accounts era -> Accounts era
drainAccounts (Withdrawals Map AccountAddress Coin
withdrawalsMap) Accounts era
accounts =
  Accounts era
accounts
    Accounts era -> (Accounts era -> Accounts era) -> Accounts era
forall a b. a -> (a -> b) -> b
& (Map (Credential Staking) (AccountState era)
 -> Identity (Map (Credential Staking) (AccountState era)))
-> Accounts era -> Identity (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL ((Map (Credential Staking) (AccountState era)
  -> Identity (Map (Credential Staking) (AccountState era)))
 -> Accounts era -> Identity (Accounts era))
-> (Map (Credential Staking) (AccountState era)
    -> Map (Credential Staking) (AccountState era))
-> Accounts era
-> Accounts era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ \Map (Credential Staking) (AccountState era)
accountsMap ->
      (AccountAddress
 -> Coin
 -> Map (Credential Staking) (AccountState era)
 -> Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
-> Map AccountAddress Coin
-> Map (Credential Staking) (AccountState era)
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey'
        ( \(AccountAddress Network
_ (AccountId Credential Staking
credential)) Coin
_withdrawalAmount ->
            (AccountState era -> AccountState era)
-> Credential Staking
-> Map (Credential Staking) (AccountState era)
-> Map (Credential Staking) (AccountState era)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((CompactForm Coin -> Identity (CompactForm Coin))
-> AccountState era -> Identity (AccountState era)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL ((CompactForm Coin -> Identity (CompactForm Coin))
 -> AccountState era -> Identity (AccountState era))
-> CompactForm Coin -> AccountState era -> AccountState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ CompactForm Coin
forall a. Monoid a => a
mempty) Credential Staking
credential
        )
        Map (Credential Staking) (AccountState era)
accountsMap
        Map AccountAddress Coin
withdrawalsMap

-- | Remove delegations of supplied credentials
removeStakePoolDelegations ::
  EraAccounts era => Set (Credential Staking) -> Accounts era -> Accounts era
removeStakePoolDelegations :: forall era.
EraAccounts era =>
Set (Credential Staking) -> Accounts era -> Accounts era
removeStakePoolDelegations Set (Credential Staking)
creds Accounts era
accounts =
  Accounts era
accounts
    Accounts era -> (Accounts era -> Accounts era) -> Accounts era
forall a b. a -> (a -> b) -> b
& (Map (Credential Staking) (AccountState era)
 -> Identity (Map (Credential Staking) (AccountState era)))
-> Accounts era -> Identity (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL
      ((Map (Credential Staking) (AccountState era)
  -> Identity (Map (Credential Staking) (AccountState era)))
 -> Accounts era -> Identity (Accounts era))
-> (Map (Credential Staking) (AccountState era)
    -> Map (Credential Staking) (AccountState era))
-> Accounts era
-> Accounts era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ( \Map (Credential Staking) (AccountState era)
accountsMap ->
             (Credential Staking
 -> Map (Credential Staking) (AccountState era)
 -> Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
-> Set (Credential Staking)
-> Map (Credential Staking) (AccountState era)
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
               ((AccountState era -> AccountState era)
-> Credential Staking
-> Map (Credential Staking) (AccountState era)
-> Map (Credential Staking) (AccountState era)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((Maybe (KeyHash StakePool) -> Identity (Maybe (KeyHash StakePool)))
-> AccountState era -> Identity (AccountState era)
forall era.
EraAccounts era =>
Lens' (AccountState era) (Maybe (KeyHash StakePool))
Lens' (AccountState era) (Maybe (KeyHash StakePool))
stakePoolDelegationAccountStateL ((Maybe (KeyHash StakePool)
  -> Identity (Maybe (KeyHash StakePool)))
 -> AccountState era -> Identity (AccountState era))
-> Maybe (KeyHash StakePool)
-> AccountState era
-> AccountState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (KeyHash StakePool)
forall a. Maybe a
Nothing))
               Map (Credential Staking) (AccountState era)
accountsMap
               Set (Credential Staking)
creds
         )