{-# 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 (kindObjectValue)
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), FromCBOR, ToCBOR)
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 (FromJSON (..), ToJSON (..), (.:), (.=))
import qualified Data.Aeson as Aeson
import Data.Aeson.Types (Parser)
import Data.Kind (Type)
import Data.Maybe (isJust)
import Data.Text (Text)
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 era -> TxCert era
  getRegPoolTxCert :: TxCert era -> Maybe (StakePoolParams era)

  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) ->
    f (TxCert era) ->
    Coin

pattern RegPoolTxCert :: EraTxCert era => StakePoolParams era -> TxCert era
pattern $mRegPoolTxCert :: forall {r} {era}.
EraTxCert era =>
TxCert era -> (StakePoolParams era -> r) -> ((# #) -> r) -> r
$bRegPoolTxCert :: forall era. EraTxCert era => StakePoolParams era -> TxCert era
RegPoolTxCert d <- (getRegPoolTxCert -> Just d)
  where
    RegPoolTxCert StakePoolParams era
d = StakePoolParams era -> TxCert era
forall era. EraTxCert era => StakePoolParams era -> TxCert era
mkRegPoolTxCert StakePoolParams era
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 era)
getPoolCertTxCert :: forall era. EraTxCert era => TxCert era -> Maybe (PoolCert era)
getPoolCertTxCert = \case
  RegPoolTxCert StakePoolParams era
poolParams -> PoolCert era -> Maybe (PoolCert era)
forall a. a -> Maybe a
Just (PoolCert era -> Maybe (PoolCert era))
-> PoolCert era -> Maybe (PoolCert era)
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> PoolCert era
forall era. StakePoolParams era -> PoolCert era
RegPool StakePoolParams era
poolParams
  RetirePoolTxCert KeyHash StakePool
poolId EpochNo
epochNo -> PoolCert era -> Maybe (PoolCert era)
forall a. a -> Maybe a
Just (PoolCert era -> Maybe (PoolCert era))
-> PoolCert era -> Maybe (PoolCert era)
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool -> EpochNo -> PoolCert era
forall era. KeyHash StakePool -> EpochNo -> PoolCert era
RetirePool KeyHash StakePool
poolId EpochNo
epochNo
  TxCert era
_ -> Maybe (PoolCert era)
forall a. Maybe a
Nothing

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

instance NoThunks (PoolCert era)

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

instance ToJSON (PoolCert era) where
  toJSON :: PoolCert era -> Value
toJSON = \case
    RegPool StakePoolParams era
poolParams ->
      Text -> [Pair] -> Value
kindObjectValue 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 era -> Value
forall a. ToJSON a => a -> Value
toJSON StakePoolParams era
poolParams]
    RetirePool KeyHash StakePool
poolId EpochNo
epochNo ->
      Text -> [Pair] -> Value
kindObjectValue
        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
        ]

instance FromJSON (PoolCert era) where
  parseJSON :: Value -> Parser (PoolCert era)
parseJSON = String
-> (Object -> Parser (PoolCert era))
-> Value
-> Parser (PoolCert era)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"PoolCert" ((Object -> Parser (PoolCert era))
 -> Value -> Parser (PoolCert era))
-> (Object -> Parser (PoolCert era))
-> Value
-> Parser (PoolCert era)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    kind <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"kind" :: Parser Text
    case kind of
      Text
"RegPool" -> StakePoolParams era -> PoolCert era
forall era. StakePoolParams era -> PoolCert era
RegPool (StakePoolParams era -> PoolCert era)
-> Parser (StakePoolParams era) -> Parser (PoolCert era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (StakePoolParams era)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"poolParams"
      Text
"RetirePool" -> KeyHash StakePool -> EpochNo -> PoolCert era
forall era. KeyHash StakePool -> EpochNo -> PoolCert era
RetirePool (KeyHash StakePool -> EpochNo -> PoolCert era)
-> Parser (KeyHash StakePool) -> Parser (EpochNo -> PoolCert era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (KeyHash StakePool)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"poolId" Parser (EpochNo -> PoolCert era)
-> Parser EpochNo -> Parser (PoolCert era)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser EpochNo
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"epochNo"
      Text
_ -> String -> Parser (PoolCert era)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (PoolCert era))
-> String -> Parser (PoolCert era)
forall a b. (a -> b) -> a -> b
$ String
"Unknown PoolCert kind: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
kind

poolCertKeyHashWitness :: PoolCert era -> KeyHash Witness
poolCertKeyHashWitness :: forall era. PoolCert era -> KeyHash Witness
poolCertKeyHashWitness = \case
  RegPool StakePoolParams era
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 era -> KeyHash StakePool
forall era. StakePoolParams era -> KeyHash StakePool
sppId StakePoolParams era
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

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