{-# 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 $bRegPoolTxCert :: forall era. EraTxCert era => PoolParams -> TxCert era
$mRegPoolTxCert :: forall {r} {era}.
EraTxCert era =>
TxCert era -> (PoolParams -> r) -> ((# #) -> r) -> r
RegPoolTxCert d <- (getRegPoolTxCert -> Just d)
  where
    RegPoolTxCert PoolParams
d = forall era. EraTxCert era => PoolParams -> TxCert era
mkRegPoolTxCert PoolParams
d

pattern RetirePoolTxCert ::
  EraTxCert era =>
  KeyHash 'StakePool ->
  EpochNo ->
  TxCert era
pattern $bRetirePoolTxCert :: forall era.
EraTxCert era =>
KeyHash 'StakePool -> EpochNo -> TxCert era
$mRetirePoolTxCert :: forall {r} {era}.
EraTxCert era =>
TxCert era
-> (KeyHash 'StakePool -> EpochNo -> r) -> ((# #) -> r) -> r
RetirePoolTxCert poolId epochNo <- (getRetirePoolTxCert -> Just (poolId, epochNo))
  where
    RetirePoolTxCert KeyHash 'StakePool
poolId EpochNo
epochNo = 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 -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PoolParams -> PoolCert
RegPool PoolParams
poolParams
  RetirePoolTxCert KeyHash 'StakePool
poolId EpochNo
epochNo -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ KeyHash 'StakePool -> EpochNo -> PoolCert
RetirePool KeyHash 'StakePool
poolId EpochNo
epochNo
  TxCert era
_ -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PoolCert] -> ShowS
$cshowList :: [PoolCert] -> ShowS
show :: PoolCert -> String
$cshow :: PoolCert -> String
showsPrec :: Int -> PoolCert -> ShowS
$cshowsPrec :: Int -> PoolCert -> ShowS
Show, 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
$cto :: forall x. Rep PoolCert x -> PoolCert
$cfrom :: forall x. PoolCert -> Rep PoolCert x
Generic, PoolCert -> PoolCert -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PoolCert -> PoolCert -> Bool
$c/= :: PoolCert -> PoolCert -> Bool
== :: PoolCert -> PoolCert -> Bool
$c== :: PoolCert -> PoolCert -> Bool
Eq, Eq 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
min :: PoolCert -> PoolCert -> PoolCert
$cmin :: PoolCert -> PoolCert -> PoolCert
max :: PoolCert -> PoolCert -> PoolCert
$cmax :: PoolCert -> PoolCert -> PoolCert
>= :: PoolCert -> PoolCert -> Bool
$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
compare :: PoolCert -> PoolCert -> Ordering
$ccompare :: PoolCert -> PoolCert -> Ordering
Ord)

instance EncCBOR PoolCert where
  encCBOR :: PoolCert -> Encoding
encCBOR =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      RegPool PoolParams
pp -> forall t. t -> Word -> Encode 'Open t
Sum PoolParams -> PoolCert
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
pp
      RetirePool KeyHash 'StakePool
kh EpochNo
eNo -> forall t. t -> Word -> Encode 'Open t
Sum KeyHash 'StakePool -> EpochNo -> PoolCert
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
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

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

instance ToJSON PoolCert where
  toJSON :: PoolCert -> Value
toJSON = \case
    RegPool PoolParams
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
poolParams]
    RetirePool KeyHash 'StakePool
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
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 -> KeyHash 'Witness
poolCertKeyHashWitness :: PoolCert -> KeyHash 'Witness
poolCertKeyHashWitness = \case
  RegPool PoolParams
poolParams -> forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall a b. (a -> b) -> a -> b
$ PoolParams -> KeyHash 'StakePool
ppId PoolParams
poolParams
  RetirePool KeyHash 'StakePool
poolId EpochNo
_ -> 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 = 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)
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)
lookupUnRegStakeTxCert

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