{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Wasm.Api.Certificate.StakeCertificate
  ( makeStakeAddressStakeDelegationCertificateImpl
  , makeStakeAddressStakeDelegationCertificateUpcomingEraImpl
  , makeStakeAddressRegistrationCertificateImpl
  , makeStakeAddressRegistrationCertificateUpcomingEraImpl
  , makeStakeAddressUnregistrationCertificateImpl
  , makeStakeAddressUnregistrationCertificateUpcomingEraImpl
  )
where

import Cardano.Api
  ( Coin (..)
  , Hash
  , PoolId
  , StakeKey
  , serialiseToCBOR
  , unStakePoolKeyHash
  )
import Cardano.Api.Address (StakeCredential (..))
import Cardano.Api.Experimental (Era (..), obtainCommonConstraints)
import Cardano.Api.Experimental qualified as Exp
import Cardano.Api.Experimental.Certificate (Certificate (..))
import Cardano.Api.Serialise.Raw qualified as Api

import Cardano.Ledger.Api (Delegatee (DelegStake))
import Cardano.Wasm.ExceptionHandling (justOrError, rightOrError)
import Cardano.Wasm.Internal.Api.Era (currentEra, upcomingEra)

import Control.Monad.Catch (MonadThrow)
import Data.ByteString.Base16 qualified as Base16
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Numeric.Natural (Natural)

-- * Type aliases for clarity

-- | A stake key hash represented as a base16-encoded string.
type StakeKeyHashBase16 = String

-- | A pool ID represented as a base16-encoded string.
type PoolIdBase16 = String

-- | Deposit amount in lovelace.
type DepositLovelace = Natural

-- | Certificate serialized to CBOR as a base16-encoded string.
type CertificateCBORBase16 = String

-- * Stake Certificate function implementation

-- | Make a certificate that delegates a stake address to a stake pool in the current era.
makeStakeAddressStakeDelegationCertificateImpl
  :: MonadThrow m => StakeKeyHashBase16 -> PoolIdBase16 -> m CertificateCBORBase16
makeStakeAddressStakeDelegationCertificateImpl :: forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> StakeKeyHashBase16 -> m StakeKeyHashBase16
makeStakeAddressStakeDelegationCertificateImpl StakeKeyHashBase16
skHashStr StakeKeyHashBase16
poolIdStr = do
  stakeCertHash <- StakeKeyHashBase16 -> m (Hash StakeKey)
forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> m (Hash StakeKey)
readHash StakeKeyHashBase16
skHashStr
  poolId <- readPoolId poolIdStr
  makeStakeAddressStakeDelegationCertificate currentEra stakeCertHash poolId

-- | Make a certificate that delegates a stake address to a stake pool in the current upcoming era.
makeStakeAddressStakeDelegationCertificateUpcomingEraImpl
  :: MonadThrow m => StakeKeyHashBase16 -> PoolIdBase16 -> m CertificateCBORBase16
makeStakeAddressStakeDelegationCertificateUpcomingEraImpl :: forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> StakeKeyHashBase16 -> m StakeKeyHashBase16
makeStakeAddressStakeDelegationCertificateUpcomingEraImpl StakeKeyHashBase16
skHashStr StakeKeyHashBase16
poolIdStr = do
  stakeCertHash <- StakeKeyHashBase16 -> m (Hash StakeKey)
forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> m (Hash StakeKey)
readHash StakeKeyHashBase16
skHashStr
  poolId <- readPoolId poolIdStr
  era <- justOrError "No upcoming era available" upcomingEra
  makeStakeAddressStakeDelegationCertificate era stakeCertHash poolId

makeStakeAddressStakeDelegationCertificate
  :: forall era m. MonadThrow m => Exp.Era era -> Hash StakeKey -> PoolId -> m CertificateCBORBase16
makeStakeAddressStakeDelegationCertificate :: forall era (m :: * -> *).
MonadThrow m =>
Era era -> Hash StakeKey -> PoolId -> m StakeKeyHashBase16
makeStakeAddressStakeDelegationCertificate Era era
era Hash StakeKey
stakeCertHash PoolId
poolId =
  Era era
-> (EraCommonConstraints era => m StakeKeyHashBase16)
-> m StakeKeyHashBase16
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => m StakeKeyHashBase16)
 -> m StakeKeyHashBase16)
-> (EraCommonConstraints era => m StakeKeyHashBase16)
-> m StakeKeyHashBase16
forall a b. (a -> b) -> a -> b
$ do
    let Certificate (LedgerEra era)
cert :: Certificate (Exp.LedgerEra era) =
          StakeCredential -> Delegatee era -> Certificate (LedgerEra era)
forall era.
IsEra era =>
StakeCredential -> Delegatee era -> Certificate (LedgerEra era)
Exp.makeStakeAddressDelegationCertificate
            (Hash StakeKey -> StakeCredential
StakeCredentialByKey Hash StakeKey
stakeCertHash)
            ( case Era era
era of
                Era era
ConwayEra -> KeyHash StakePool -> Delegatee
DelegStake (KeyHash StakePool -> Delegatee) -> KeyHash StakePool -> Delegatee
forall a b. (a -> b) -> a -> b
$ PoolId -> KeyHash StakePool
unStakePoolKeyHash PoolId
poolId
                Era era
DijkstraEra -> KeyHash StakePool -> Delegatee
DelegStake (KeyHash StakePool -> Delegatee) -> KeyHash StakePool -> Delegatee
forall a b. (a -> b) -> a -> b
$ PoolId -> KeyHash StakePool
unStakePoolKeyHash PoolId
poolId
            )
    StakeKeyHashBase16 -> m StakeKeyHashBase16
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StakeKeyHashBase16 -> m StakeKeyHashBase16)
-> StakeKeyHashBase16 -> m StakeKeyHashBase16
forall a b. (a -> b) -> a -> b
$ Era era -> Certificate (LedgerEra era) -> StakeKeyHashBase16
forall era.
Era era -> Certificate (LedgerEra era) -> StakeKeyHashBase16
serialiseCertificateToCBOR Era era
era Certificate (LedgerEra era)
cert

-- | Make a stake address registration certificate in the current era.
makeStakeAddressRegistrationCertificateImpl
  :: MonadThrow m => StakeKeyHashBase16 -> DepositLovelace -> m CertificateCBORBase16
makeStakeAddressRegistrationCertificateImpl :: forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> DepositLovelace -> m StakeKeyHashBase16
makeStakeAddressRegistrationCertificateImpl StakeKeyHashBase16
skHashStr DepositLovelace
deposit = do
  skHash <- StakeKeyHashBase16 -> m (Hash StakeKey)
forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> m (Hash StakeKey)
readHash StakeKeyHashBase16
skHashStr
  makeStakeAddressRegistrationCertificateWrapper currentEra skHash deposit

--  | Make a stake address registration certificate in the upcoming era.
makeStakeAddressRegistrationCertificateUpcomingEraImpl
  :: MonadThrow m => StakeKeyHashBase16 -> DepositLovelace -> m CertificateCBORBase16
makeStakeAddressRegistrationCertificateUpcomingEraImpl :: forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> DepositLovelace -> m StakeKeyHashBase16
makeStakeAddressRegistrationCertificateUpcomingEraImpl StakeKeyHashBase16
skHashStr DepositLovelace
deposit = do
  skHash <- StakeKeyHashBase16 -> m (Hash StakeKey)
forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> m (Hash StakeKey)
readHash StakeKeyHashBase16
skHashStr
  era <- justOrError "No upcoming era available" upcomingEra
  makeStakeAddressRegistrationCertificateWrapper era skHash deposit

makeStakeAddressRegistrationCertificateWrapper
  :: forall era m. MonadThrow m => Era era -> Hash StakeKey -> DepositLovelace -> m CertificateCBORBase16
makeStakeAddressRegistrationCertificateWrapper :: forall era (m :: * -> *).
MonadThrow m =>
Era era -> Hash StakeKey -> DepositLovelace -> m StakeKeyHashBase16
makeStakeAddressRegistrationCertificateWrapper Era era
era Hash StakeKey
skHash DepositLovelace
deposit =
  Era era
-> (EraCommonConstraints era => m StakeKeyHashBase16)
-> m StakeKeyHashBase16
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => m StakeKeyHashBase16)
 -> m StakeKeyHashBase16)
-> (EraCommonConstraints era => m StakeKeyHashBase16)
-> m StakeKeyHashBase16
forall a b. (a -> b) -> a -> b
$ do
    let Certificate (LedgerEra era)
cert :: Certificate (Exp.LedgerEra era) =
          StakeCredential -> Coin -> Certificate (LedgerEra era)
forall era.
IsEra era =>
StakeCredential -> Coin -> Certificate (LedgerEra era)
Exp.makeStakeAddressRegistrationCertificate
            (Hash StakeKey -> StakeCredential
StakeCredentialByKey Hash StakeKey
skHash)
            (Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ DepositLovelace -> Integer
forall a. Integral a => a -> Integer
toInteger DepositLovelace
deposit)
    StakeKeyHashBase16 -> m StakeKeyHashBase16
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StakeKeyHashBase16 -> m StakeKeyHashBase16)
-> StakeKeyHashBase16 -> m StakeKeyHashBase16
forall a b. (a -> b) -> a -> b
$ Era era -> Certificate (LedgerEra era) -> StakeKeyHashBase16
forall era.
Era era -> Certificate (LedgerEra era) -> StakeKeyHashBase16
serialiseCertificateToCBOR Era era
era Certificate (LedgerEra era)
cert

-- | Make a stake address unregistration certificate in the current era.
makeStakeAddressUnregistrationCertificateImpl
  :: MonadThrow m => StakeKeyHashBase16 -> DepositLovelace -> m CertificateCBORBase16
makeStakeAddressUnregistrationCertificateImpl :: forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> DepositLovelace -> m StakeKeyHashBase16
makeStakeAddressUnregistrationCertificateImpl StakeKeyHashBase16
skHashStr DepositLovelace
deposit = do
  skHash <- StakeKeyHashBase16 -> m (Hash StakeKey)
forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> m (Hash StakeKey)
readHash StakeKeyHashBase16
skHashStr
  makeStakeAddressUnregistrationCertificateWrapper currentEra skHash deposit

-- | Make a stake address unregistration certificate in the upcoming era.
makeStakeAddressUnregistrationCertificateUpcomingEraImpl
  :: MonadThrow m => StakeKeyHashBase16 -> DepositLovelace -> m CertificateCBORBase16
makeStakeAddressUnregistrationCertificateUpcomingEraImpl :: forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> DepositLovelace -> m StakeKeyHashBase16
makeStakeAddressUnregistrationCertificateUpcomingEraImpl StakeKeyHashBase16
skHashStr DepositLovelace
deposit = do
  skHash <- StakeKeyHashBase16 -> m (Hash StakeKey)
forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> m (Hash StakeKey)
readHash StakeKeyHashBase16
skHashStr
  era <- justOrError "No upcoming era available" upcomingEra
  makeStakeAddressUnregistrationCertificateWrapper era skHash deposit

makeStakeAddressUnregistrationCertificateWrapper
  :: forall era m. MonadThrow m => Era era -> Hash StakeKey -> DepositLovelace -> m CertificateCBORBase16
makeStakeAddressUnregistrationCertificateWrapper :: forall era (m :: * -> *).
MonadThrow m =>
Era era -> Hash StakeKey -> DepositLovelace -> m StakeKeyHashBase16
makeStakeAddressUnregistrationCertificateWrapper Era era
era Hash StakeKey
skHash DepositLovelace
deposit =
  Era era
-> (EraCommonConstraints era => m StakeKeyHashBase16)
-> m StakeKeyHashBase16
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => m StakeKeyHashBase16)
 -> m StakeKeyHashBase16)
-> (EraCommonConstraints era => m StakeKeyHashBase16)
-> m StakeKeyHashBase16
forall a b. (a -> b) -> a -> b
$ do
    let Certificate (LedgerEra era)
cert :: Certificate (Exp.LedgerEra era) =
          StakeCredential -> Coin -> Certificate (LedgerEra era)
forall era.
IsEra era =>
StakeCredential -> Coin -> Certificate (LedgerEra era)
Exp.makeStakeAddressUnregistrationCertificate
            (Hash StakeKey -> StakeCredential
StakeCredentialByKey Hash StakeKey
skHash)
            (Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ DepositLovelace -> Integer
forall a. Integral a => a -> Integer
toInteger DepositLovelace
deposit)
    StakeKeyHashBase16 -> m StakeKeyHashBase16
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StakeKeyHashBase16 -> m StakeKeyHashBase16)
-> StakeKeyHashBase16 -> m StakeKeyHashBase16
forall a b. (a -> b) -> a -> b
$ Era era -> Certificate (LedgerEra era) -> StakeKeyHashBase16
forall era.
Era era -> Certificate (LedgerEra era) -> StakeKeyHashBase16
serialiseCertificateToCBOR Era era
era Certificate (LedgerEra era)
cert

serialiseCertificateToCBOR
  :: Exp.Era era -> Certificate (Exp.LedgerEra era) -> CertificateCBORBase16
serialiseCertificateToCBOR :: forall era.
Era era -> Certificate (LedgerEra era) -> StakeKeyHashBase16
serialiseCertificateToCBOR Era era
era Certificate (LedgerEra era)
cert =
  Era era
-> (EraCommonConstraints era => StakeKeyHashBase16)
-> StakeKeyHashBase16
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => StakeKeyHashBase16)
 -> StakeKeyHashBase16)
-> (EraCommonConstraints era => StakeKeyHashBase16)
-> StakeKeyHashBase16
forall a b. (a -> b) -> a -> b
$ do
    Text -> StakeKeyHashBase16
Text.unpack (Text -> StakeKeyHashBase16) -> Text -> StakeKeyHashBase16
forall a b. (a -> b) -> a -> b
$
      ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$
        ByteString -> ByteString
Base16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
          Certificate (LedgerEra era) -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR
            Certificate (LedgerEra era)
cert

readHash :: MonadThrow m => StakeKeyHashBase16 -> m (Hash StakeKey)
readHash :: forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> m (Hash StakeKey)
readHash = Either RawBytesHexError (Hash StakeKey) -> m (Hash StakeKey)
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Show e) =>
Either e a -> m a
rightOrError (Either RawBytesHexError (Hash StakeKey) -> m (Hash StakeKey))
-> (StakeKeyHashBase16 -> Either RawBytesHexError (Hash StakeKey))
-> StakeKeyHashBase16
-> m (Hash StakeKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either RawBytesHexError (Hash StakeKey)
forall a.
SerialiseAsRawBytes a =>
ByteString -> Either RawBytesHexError a
Api.deserialiseFromRawBytesHex (ByteString -> Either RawBytesHexError (Hash StakeKey))
-> (StakeKeyHashBase16 -> ByteString)
-> StakeKeyHashBase16
-> Either RawBytesHexError (Hash StakeKey)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> ByteString)
-> (StakeKeyHashBase16 -> Text) -> StakeKeyHashBase16 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakeKeyHashBase16 -> Text
Text.pack

readPoolId :: MonadThrow m => PoolIdBase16 -> m PoolId
readPoolId :: forall (m :: * -> *).
MonadThrow m =>
StakeKeyHashBase16 -> m PoolId
readPoolId = Either RawBytesHexError PoolId -> m PoolId
forall (m :: * -> *) e a.
(HasCallStack, MonadThrow m, Show e) =>
Either e a -> m a
rightOrError (Either RawBytesHexError PoolId -> m PoolId)
-> (StakeKeyHashBase16 -> Either RawBytesHexError PoolId)
-> StakeKeyHashBase16
-> m PoolId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either RawBytesHexError PoolId
forall a.
SerialiseAsRawBytes a =>
ByteString -> Either RawBytesHexError a
Api.deserialiseFromRawBytesHex (ByteString -> Either RawBytesHexError PoolId)
-> (StakeKeyHashBase16 -> ByteString)
-> StakeKeyHashBase16
-> Either RawBytesHexError PoolId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8 (Text -> ByteString)
-> (StakeKeyHashBase16 -> Text) -> StakeKeyHashBase16 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakeKeyHashBase16 -> Text
Text.pack