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

module Cardano.Ledger.Core.TxCert (
  EraTxCert (..),
  pattern RegPoolTxCert,
  pattern RetirePoolTxCert,
  PoolCert (..),
  getPoolCertTxCert,
  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)
import Cardano.Ledger.Core.PParams (PParams)
import Cardano.Ledger.Core.Translation
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Hashes (ScriptHash)
import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..), asWitness)
import Cardano.Ledger.Slot (EpochNo (..))
import Cardano.Ledger.State.StakePool (StakePoolParams (sppId))
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)

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

  mkRegPoolTxCert :: StakePoolParams -> TxCert era
  getRegPoolTxCert :: TxCert era -> Maybe StakePoolParams

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

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

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

  -- | Compute the total deposits from a list of certificates.
  getTotalDepositsTxCerts ::
    Foldable f =>
    PParams era ->
    -- | Check whether stake pool is registered or not
    (KeyHash StakePool -> 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 -> Maybe Coin) ->
    -- | Lookup current deposit for DRep credential if one is registered
    (Credential DRepRole -> Maybe Coin) ->
    f (TxCert era) ->
    Coin

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

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

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

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

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

instance NoThunks PoolCert

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

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

poolCertKeyHashWitness :: PoolCert -> KeyHash Witness
poolCertKeyHashWitness :: PoolCert -> KeyHash Witness
poolCertKeyHashWitness = \case
  RegPool StakePoolParams
stakePoolParams -> KeyHash StakePool -> KeyHash Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a Witness
asWitness (KeyHash StakePool -> KeyHash Witness)
-> KeyHash StakePool -> KeyHash Witness
forall a b. (a -> b) -> a -> b
$ StakePoolParams -> KeyHash StakePool
sppId StakePoolParams
stakePoolParams
  RetirePool KeyHash StakePool
poolId EpochNo
_ -> KeyHash StakePool -> KeyHash Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a Witness
asWitness KeyHash StakePool
poolId

-- | Check if supplied TxCert is a stake registering certificate
isRegStakeTxCert :: EraTxCert era => TxCert era -> Bool
isRegStakeTxCert :: forall era. EraTxCert era => TxCert era -> Bool
isRegStakeTxCert = Maybe (Credential Staking) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Credential Staking) -> Bool)
-> (TxCert era -> Maybe (Credential Staking)) -> TxCert era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxCert era -> Maybe (Credential Staking)
forall era.
EraTxCert era =>
TxCert era -> Maybe (Credential Staking)
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 = Maybe (Credential Staking) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Credential Staking) -> Bool)
-> (TxCert era -> Maybe (Credential Staking)) -> TxCert era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxCert era -> Maybe (Credential Staking)
forall era.
EraTxCert era =>
TxCert era -> Maybe (Credential Staking)
lookupUnRegStakeTxCert

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