{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ViewPatterns #-}

module Cardano.Ledger.Core.TxCert (
  EraTxCert (..),
  pattern RegPoolTxCert,
  pattern RetirePoolTxCert,
  Delegation (..),
  PoolCert (..),
  getPoolCertTxCert,
  poolCWitness,
  poolCertKeyHashWitness,
  isRegStakeTxCert,
  isUnRegStakeTxCert,
)
where

import Cardano.Ledger.BaseTypes (kindObject)
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), FromCBOR, ToCBOR)
import Cardano.Ledger.Binary.Coders (Encode (..), encode, (!>))
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Core.Era (Era (EraCrypto))
import Cardano.Ledger.Core.PParams (PParams)
import Cardano.Ledger.Core.Translation
import Cardano.Ledger.Credential (Credential (..), StakeCredential)
import Cardano.Ledger.Crypto
import Cardano.Ledger.Hashes (ScriptHash)
import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..), asWitness)
import Cardano.Ledger.PoolParams (PoolParams (ppId))
import Cardano.Ledger.Slot (EpochNo (..))
import Control.DeepSeq (NFData (..), rwhnf)
import Data.Aeson (ToJSON (..), (.=))
import Data.Kind (Type)
import Data.Maybe (isJust)
import Data.Void (Void)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))

class
  ( Era era
  , ToJSON (TxCert era)
  , DecCBOR (TxCert era)
  , EncCBOR (TxCert era)
  , ToCBOR (TxCert era)
  , FromCBOR (TxCert era)
  , NoThunks (TxCert era)
  , NFData (TxCert era)
  , Show (TxCert era)
  , Ord (TxCert era)
  , Eq (TxCert era)
  ) =>
  EraTxCert era
  where
  type TxCert era = (r :: Type) | r -> era

  type TxCertUpgradeError era :: Type
  type TxCertUpgradeError era = Void

  -- | Every era, except Shelley, must be able to upgrade a `TxCert` from a previous
  -- era. However, not all certificates can be upgraded, because some eras lose some of
  -- the certificates, thus return type is an `Either`. Eg. from Babbage to Conway: MIR
  -- and Genesis certificates were removed.
  upgradeTxCert ::
    EraTxCert (PreviousEra era) =>
    TxCert (PreviousEra era) ->
    Either (TxCertUpgradeError era) (TxCert era)

  -- | Return a witness key whenever a certificate requires one
  getVKeyWitnessTxCert :: TxCert era -> Maybe (KeyHash 'Witness (EraCrypto era))

  -- | Return a ScriptHash for certificate types that require a witness
  getScriptWitnessTxCert :: TxCert era -> Maybe (ScriptHash (EraCrypto era))

  mkRegPoolTxCert :: PoolParams (EraCrypto era) -> TxCert era
  getRegPoolTxCert :: TxCert era -> Maybe (PoolParams (EraCrypto era))

  mkRetirePoolTxCert :: KeyHash 'StakePool (EraCrypto era) -> EpochNo -> TxCert era
  getRetirePoolTxCert :: TxCert era -> Maybe (KeyHash 'StakePool (EraCrypto era), EpochNo)

  -- | Extract staking credential from any certificate that can register such credential
  lookupRegStakeTxCert :: TxCert era -> Maybe (Credential 'Staking (EraCrypto era))

  -- | Extract staking credential from any certificate that can unregister such credential
  lookupUnRegStakeTxCert :: TxCert era -> Maybe (Credential 'Staking (EraCrypto era))

  -- | Compute the total deposits from a list of certificates.
  getTotalDepositsTxCerts ::
    Foldable f =>
    PParams era ->
    -- | Check whether stake pool is registered or not
    (KeyHash 'StakePool (EraCrypto era) -> Bool) ->
    f (TxCert era) ->
    Coin

  -- | Compute the total refunds from a list of certificates.
  getTotalRefundsTxCerts ::
    Foldable f =>
    PParams era ->
    -- | Lookup current deposit for Staking credential if one is registered
    (Credential 'Staking (EraCrypto era) -> Maybe Coin) ->
    -- | Lookup current deposit for DRep credential if one is registered
    (Credential 'DRepRole (EraCrypto era) -> Maybe Coin) ->
    f (TxCert era) ->
    Coin

pattern RegPoolTxCert :: EraTxCert era => PoolParams (EraCrypto era) -> TxCert era
pattern $bRegPoolTxCert :: forall era.
EraTxCert era =>
PoolParams (EraCrypto era) -> TxCert era
$mRegPoolTxCert :: forall {r} {era}.
EraTxCert era =>
TxCert era
-> (PoolParams (EraCrypto era) -> r) -> ((# #) -> r) -> r
RegPoolTxCert d <- (getRegPoolTxCert -> Just d)
  where
    RegPoolTxCert PoolParams (EraCrypto era)
d = forall era.
EraTxCert era =>
PoolParams (EraCrypto era) -> TxCert era
mkRegPoolTxCert PoolParams (EraCrypto era)
d

pattern RetirePoolTxCert ::
  EraTxCert era =>
  KeyHash 'StakePool (EraCrypto era) ->
  EpochNo ->
  TxCert era
pattern $bRetirePoolTxCert :: forall era.
EraTxCert era =>
KeyHash 'StakePool (EraCrypto era) -> EpochNo -> TxCert era
$mRetirePoolTxCert :: forall {r} {era}.
EraTxCert era =>
TxCert era
-> (KeyHash 'StakePool (EraCrypto era) -> EpochNo -> r)
-> ((# #) -> r)
-> r
RetirePoolTxCert poolId epochNo <- (getRetirePoolTxCert -> Just (poolId, epochNo))
  where
    RetirePoolTxCert KeyHash 'StakePool (EraCrypto era)
poolId EpochNo
epochNo = forall era.
EraTxCert era =>
KeyHash 'StakePool (EraCrypto era) -> EpochNo -> TxCert era
mkRetirePoolTxCert KeyHash 'StakePool (EraCrypto era)
poolId EpochNo
epochNo

getPoolCertTxCert :: EraTxCert era => TxCert era -> Maybe (PoolCert (EraCrypto era))
getPoolCertTxCert :: forall era.
EraTxCert era =>
TxCert era -> Maybe (PoolCert (EraCrypto era))
getPoolCertTxCert = \case
  RegPoolTxCert PoolParams (EraCrypto era)
poolParams -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall c. PoolParams c -> PoolCert c
RegPool PoolParams (EraCrypto era)
poolParams
  RetirePoolTxCert KeyHash 'StakePool (EraCrypto era)
poolId EpochNo
epochNo -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall c. KeyHash 'StakePool c -> EpochNo -> PoolCert c
RetirePool KeyHash 'StakePool (EraCrypto era)
poolId EpochNo
epochNo
  TxCert era
_ -> forall a. Maybe a
Nothing

-- | The delegation of one stake key to another.
data Delegation c = Delegation
  { forall c. Delegation c -> StakeCredential c
dDelegator :: !(StakeCredential c)
  , forall c. Delegation c -> KeyHash 'StakePool c
dDelegatee :: !(KeyHash 'StakePool c)
  }
  deriving (Delegation c -> Delegation c -> Bool
forall c. Delegation c -> Delegation c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Delegation c -> Delegation c -> Bool
$c/= :: forall c. Delegation c -> Delegation c -> Bool
== :: Delegation c -> Delegation c -> Bool
$c== :: forall c. Delegation c -> Delegation c -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (Delegation c) x -> Delegation c
forall c x. Delegation c -> Rep (Delegation c) x
$cto :: forall c x. Rep (Delegation c) x -> Delegation c
$cfrom :: forall c x. Delegation c -> Rep (Delegation c) x
Generic, Int -> Delegation c -> ShowS
forall c. Int -> Delegation c -> ShowS
forall c. [Delegation c] -> ShowS
forall c. Delegation c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Delegation c] -> ShowS
$cshowList :: forall c. [Delegation c] -> ShowS
show :: Delegation c -> String
$cshow :: forall c. Delegation c -> String
showsPrec :: Int -> Delegation c -> ShowS
$cshowsPrec :: forall c. Int -> Delegation c -> ShowS
Show)
{-# DEPRECATED Delegation "No longer used" #-}

instance NFData (Delegation c) where
  rnf :: Delegation c -> ()
rnf = forall a. a -> ()
rwhnf

instance NoThunks (Delegation c)

data PoolCert c
  = -- | A stake pool registration certificate.
    RegPool !(PoolParams c)
  | -- | A stake pool retirement certificate.
    RetirePool !(KeyHash 'StakePool c) !EpochNo
  deriving (Int -> PoolCert c -> ShowS
forall c. Int -> PoolCert c -> ShowS
forall c. [PoolCert c] -> ShowS
forall c. PoolCert c -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PoolCert c] -> ShowS
$cshowList :: forall c. [PoolCert c] -> ShowS
show :: PoolCert c -> String
$cshow :: forall c. PoolCert c -> String
showsPrec :: Int -> PoolCert c -> ShowS
$cshowsPrec :: forall c. Int -> PoolCert c -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x. Rep (PoolCert c) x -> PoolCert c
forall c x. PoolCert c -> Rep (PoolCert c) x
$cto :: forall c x. Rep (PoolCert c) x -> PoolCert c
$cfrom :: forall c x. PoolCert c -> Rep (PoolCert c) x
Generic, PoolCert c -> PoolCert c -> Bool
forall c. PoolCert c -> PoolCert c -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PoolCert c -> PoolCert c -> Bool
$c/= :: forall c. PoolCert c -> PoolCert c -> Bool
== :: PoolCert c -> PoolCert c -> Bool
$c== :: forall c. PoolCert c -> PoolCert c -> Bool
Eq, PoolCert c -> PoolCert c -> Bool
PoolCert c -> PoolCert c -> Ordering
forall c. Eq (PoolCert c)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall c. PoolCert c -> PoolCert c -> Bool
forall c. PoolCert c -> PoolCert c -> Ordering
forall c. PoolCert c -> PoolCert c -> PoolCert c
min :: PoolCert c -> PoolCert c -> PoolCert c
$cmin :: forall c. PoolCert c -> PoolCert c -> PoolCert c
max :: PoolCert c -> PoolCert c -> PoolCert c
$cmax :: forall c. PoolCert c -> PoolCert c -> PoolCert c
>= :: PoolCert c -> PoolCert c -> Bool
$c>= :: forall c. PoolCert c -> PoolCert c -> Bool
> :: PoolCert c -> PoolCert c -> Bool
$c> :: forall c. PoolCert c -> PoolCert c -> Bool
<= :: PoolCert c -> PoolCert c -> Bool
$c<= :: forall c. PoolCert c -> PoolCert c -> Bool
< :: PoolCert c -> PoolCert c -> Bool
$c< :: forall c. PoolCert c -> PoolCert c -> Bool
compare :: PoolCert c -> PoolCert c -> Ordering
$ccompare :: forall c. PoolCert c -> PoolCert c -> Ordering
Ord)

instance Crypto c => EncCBOR (PoolCert c) where
  encCBOR :: PoolCert c -> Encoding
encCBOR =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      RegPool PoolParams c
pp -> forall t. t -> Word -> Encode 'Open t
Sum forall c. PoolParams c -> PoolCert c
RegPool Word
0 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PoolParams c
pp
      RetirePool KeyHash 'StakePool c
kh EpochNo
eNo -> forall t. t -> Word -> Encode 'Open t
Sum forall c. KeyHash 'StakePool c -> EpochNo -> PoolCert c
RetirePool Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To KeyHash 'StakePool c
kh forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To EpochNo
eNo

instance NoThunks (PoolCert c)

instance NFData (PoolCert c) where
  rnf :: PoolCert c -> ()
rnf = forall a. a -> ()
rwhnf

instance Crypto c => ToJSON (PoolCert c) where
  toJSON :: PoolCert c -> Value
toJSON = \case
    RegPool PoolParams c
poolParams ->
      Text -> [Pair] -> Value
kindObject Text
"RegPool" [Key
"poolParams" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON PoolParams c
poolParams]
    RetirePool KeyHash 'StakePool c
poolId EpochNo
epochNo ->
      Text -> [Pair] -> Value
kindObject Text
"RetirePool" forall a b. (a -> b) -> a -> b
$
        [ Key
"poolId" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON KeyHash 'StakePool c
poolId
        , Key
"epochNo" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON EpochNo
epochNo
        ]

poolCertKeyHashWitness :: PoolCert c -> KeyHash 'Witness c
poolCertKeyHashWitness :: forall c. PoolCert c -> KeyHash 'Witness c
poolCertKeyHashWitness = \case
  RegPool PoolParams c
poolParams -> forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness forall a b. (a -> b) -> a -> b
$ forall c. PoolParams c -> KeyHash 'StakePool c
ppId PoolParams c
poolParams
  RetirePool KeyHash 'StakePool c
poolId EpochNo
_ -> forall (a :: KeyRole -> * -> *) (r :: KeyRole) c.
HasKeyRole a =>
a r c -> a 'Witness c
asWitness KeyHash 'StakePool c
poolId

poolCWitness :: PoolCert c -> Credential 'StakePool c
poolCWitness :: forall c. PoolCert c -> Credential 'StakePool c
poolCWitness (RegPool PoolParams c
pool) = forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall a b. (a -> b) -> a -> b
$ forall c. PoolParams c -> KeyHash 'StakePool c
ppId PoolParams c
pool
poolCWitness (RetirePool KeyHash 'StakePool c
k EpochNo
_) = forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'StakePool c
k
{-# DEPRECATED poolCWitness "As useless. PoolIds have nothing to do with credentials" #-}

-- | Check if supplied TxCert is a stake registering certificate
isRegStakeTxCert :: EraTxCert era => TxCert era -> Bool
isRegStakeTxCert :: forall era. EraTxCert era => TxCert era -> Bool
isRegStakeTxCert = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxCert era =>
TxCert era -> Maybe (Credential 'Staking (EraCrypto era))
lookupRegStakeTxCert

-- | Check if supplied TxCert is a stake un-registering certificate
isUnRegStakeTxCert :: EraTxCert era => TxCert era -> Bool
isUnRegStakeTxCert :: forall era. EraTxCert era => TxCert era -> Bool
isUnRegStakeTxCert = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxCert era =>
TxCert era -> Maybe (Credential 'Staking (EraCrypto era))
lookupUnRegStakeTxCert

-- =================================================================