{-# 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,
  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.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)

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

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

  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 => PoolParams -> TxCert era
pattern $mRegPoolTxCert :: forall {r} {era}.
EraTxCert era =>
TxCert era -> (PoolParams -> r) -> ((# #) -> r) -> r
$bRegPoolTxCert :: forall era. EraTxCert era => PoolParams -> TxCert era
RegPoolTxCert d <- (getRegPoolTxCert -> Just d)
  where
    RegPoolTxCert PoolParams
d = PoolParams -> TxCert era
forall era. EraTxCert era => PoolParams -> TxCert era
mkRegPoolTxCert PoolParams
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 PoolParams
poolParams -> PoolCert -> Maybe PoolCert
forall a. a -> Maybe a
Just (PoolCert -> Maybe PoolCert) -> PoolCert -> Maybe PoolCert
forall a b. (a -> b) -> a -> b
$ PoolParams -> PoolCert
RegPool PoolParams
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 !PoolParams
  | -- | 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 PoolParams
pp -> (PoolParams -> PoolCert)
-> Word -> Encode 'Open (PoolParams -> PoolCert)
forall t. t -> Word -> Encode 'Open t
Sum PoolParams -> PoolCert
RegPool Word
0 Encode 'Open (PoolParams -> PoolCert)
-> Encode ('Closed 'Dense) PoolParams -> Encode 'Open PoolCert
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> PoolParams -> Encode ('Closed 'Dense) PoolParams
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PoolParams
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 PoolParams
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
.= PoolParams -> Value
forall a. ToJSON a => a -> Value
toJSON PoolParams
poolParams]
    RetirePool KeyHash 'StakePool
poolId EpochNo
epochNo ->
      Text -> [Pair] -> Value
kindObject Text
"RetirePool" ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
        [ 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 PoolParams
poolParams -> 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
$ PoolParams -> KeyHash 'StakePool
ppId PoolParams
poolParams
  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

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