{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.CLI.Compatible.StakeAddress.Run
  ( runCompatibleStakeAddressCmds
  )
where

import Cardano.Api
import Cardano.Api.Ledger qualified as L

import Cardano.CLI.Compatible.Exception
import Cardano.CLI.Compatible.StakeAddress.Command
import Cardano.CLI.Read
import Cardano.CLI.Type.Error.StakeAddressRegistrationError
import Cardano.CLI.Type.Key

runCompatibleStakeAddressCmds
  :: ()
  => CompatibleStakeAddressCmds era
  -> CIO e ()
runCompatibleStakeAddressCmds :: forall era e. CompatibleStakeAddressCmds era -> CIO e ()
runCompatibleStakeAddressCmds = \case
  CompatibleStakeAddressRegistrationCertificateCmd ShelleyBasedEra era
sbe StakeIdentifier
stakeIdentifier Maybe (Featured ConwayEraOnwards era Coin)
mDeposit File () 'Out
outputFp ->
    ShelleyBasedEra era
-> StakeIdentifier
-> Maybe (Featured ConwayEraOnwards era Coin)
-> File () 'Out
-> CIO e ()
forall era e.
ShelleyBasedEra era
-> StakeIdentifier
-> Maybe (Featured ConwayEraOnwards era Coin)
-> File () 'Out
-> CIO e ()
runStakeAddressRegistrationCertificateCmd ShelleyBasedEra era
sbe StakeIdentifier
stakeIdentifier Maybe (Featured ConwayEraOnwards era Coin)
mDeposit File () 'Out
outputFp
  CompatibleStakeAddressStakeDelegationCertificateCmd
    ShelleyBasedEra era
sbe
    StakeIdentifier
stakeIdentifier
    StakePoolKeyHashSource
stkPoolVerKeyHashOrFp
    File () 'Out
outputFp ->
      ShelleyBasedEra era
-> StakeIdentifier
-> StakePoolKeyHashSource
-> File () 'Out
-> CIO e ()
forall era e.
ShelleyBasedEra era
-> StakeIdentifier
-> StakePoolKeyHashSource
-> File () 'Out
-> CIO e ()
runStakeAddressStakeDelegationCertificateCmd ShelleyBasedEra era
sbe StakeIdentifier
stakeIdentifier StakePoolKeyHashSource
stkPoolVerKeyHashOrFp File () 'Out
outputFp

runStakeAddressRegistrationCertificateCmd
  :: ()
  => ShelleyBasedEra era
  -> StakeIdentifier
  -> Maybe (Featured ConwayEraOnwards era Lovelace)
  -- ^ Deposit required in conway era
  -> File () Out
  -> CIO e ()
runStakeAddressRegistrationCertificateCmd :: forall era e.
ShelleyBasedEra era
-> StakeIdentifier
-> Maybe (Featured ConwayEraOnwards era Coin)
-> File () 'Out
-> CIO e ()
runStakeAddressRegistrationCertificateCmd ShelleyBasedEra era
sbe StakeIdentifier
stakeIdentifier Maybe (Featured ConwayEraOnwards era Coin)
mDeposit File () 'Out
oFp = do
  StakeCredential
stakeCred <-
    StakeIdentifier -> CIO e StakeCredential
forall e. StakeIdentifier -> CIO e StakeCredential
getStakeCredentialFromIdentifier StakeIdentifier
stakeIdentifier

  StakeAddressRequirements era
req <- ShelleyBasedEra era
-> StakeCredential
-> Maybe (Featured ConwayEraOnwards era Coin)
-> CIO e (StakeAddressRequirements era)
forall era e.
ShelleyBasedEra era
-> StakeCredential
-> Maybe (Featured ConwayEraOnwards era Coin)
-> CIO e (StakeAddressRequirements era)
createRegistrationCertRequirements ShelleyBasedEra era
sbe StakeCredential
stakeCred Maybe (Featured ConwayEraOnwards era Coin)
mDeposit

  let regCert :: Certificate era
regCert = StakeAddressRequirements era -> Certificate era
forall era. StakeAddressRequirements era -> Certificate era
makeStakeAddressRegistrationCertificate StakeAddressRequirements era
req

  forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli @(FileError ())
    (IO (Either (FileError ()) ()) -> RIO e ())
-> IO (Either (FileError ()) ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ File () 'Out -> ByteString -> IO (Either (FileError ()) ())
forall (m :: * -> *) content e.
MonadIO m =>
File content 'Out -> ByteString -> m (Either (FileError e) ())
writeLazyByteStringFile
      File () 'Out
oFp
    (ByteString -> IO (Either (FileError ()) ()))
-> ByteString -> IO (Either (FileError ()) ())
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => ByteString) -> ByteString
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe
    ((ShelleyBasedEraConstraints era => ByteString) -> ByteString)
-> (ShelleyBasedEraConstraints era => ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe TextEnvelopeDescr -> Certificate era -> ByteString
forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> ByteString
textEnvelopeToJSON (TextEnvelopeDescr -> Maybe TextEnvelopeDescr
forall a. a -> Maybe a
Just TextEnvelopeDescr
regCertDesc) Certificate era
regCert
 where
  regCertDesc :: TextEnvelopeDescr
  regCertDesc :: TextEnvelopeDescr
regCertDesc = TextEnvelopeDescr
"Stake Address Registration Certificate"

createRegistrationCertRequirements
  :: ()
  => ShelleyBasedEra era
  -> StakeCredential
  -> Maybe (Featured ConwayEraOnwards era Lovelace)
  -- ^ Deposit required in conway era
  -> CIO e (StakeAddressRequirements era)
createRegistrationCertRequirements :: forall era e.
ShelleyBasedEra era
-> StakeCredential
-> Maybe (Featured ConwayEraOnwards era Coin)
-> CIO e (StakeAddressRequirements era)
createRegistrationCertRequirements ShelleyBasedEra era
sbe StakeCredential
stakeCred Maybe (Featured ConwayEraOnwards era Coin)
mDeposit =
  (ShelleyToBabbageEraConstraints era =>
 ShelleyToBabbageEra era -> RIO e (StakeAddressRequirements era))
-> (ConwayEraOnwardsConstraints era =>
    ConwayEraOnwards era -> RIO e (StakeAddressRequirements era))
-> ShelleyBasedEra era
-> RIO e (StakeAddressRequirements era)
forall era a.
(ShelleyToBabbageEraConstraints era =>
 ShelleyToBabbageEra era -> a)
-> (ConwayEraOnwardsConstraints era => ConwayEraOnwards era -> a)
-> ShelleyBasedEra era
-> a
caseShelleyToBabbageOrConwayEraOnwards
    (\ShelleyToBabbageEra era
stb -> StakeAddressRequirements era
-> RIO e (StakeAddressRequirements era)
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StakeAddressRequirements era
 -> RIO e (StakeAddressRequirements era))
-> StakeAddressRequirements era
-> RIO e (StakeAddressRequirements era)
forall a b. (a -> b) -> a -> b
$ ShelleyToBabbageEra era
-> StakeCredential -> StakeAddressRequirements era
forall era.
ShelleyToBabbageEra era
-> StakeCredential -> StakeAddressRequirements era
StakeAddrRegistrationPreConway ShelleyToBabbageEra era
stb StakeCredential
stakeCred)
    ( \ConwayEraOnwards era
ceo -> do
        case Maybe (Featured ConwayEraOnwards era Coin)
mDeposit of
          Maybe (Featured ConwayEraOnwards era Coin)
Nothing ->
            -- This case is made impossible by the parser, that distinguishes between Conway
            -- and pre-Conway.
            StakeAddressRegistrationError
-> RIO e (StakeAddressRequirements era)
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError StakeAddressRegistrationError
StakeAddressRegistrationDepositRequired
          Just (Featured ConwayEraOnwards era
_ Coin
dep) ->
            StakeAddressRequirements era
-> RIO e (StakeAddressRequirements era)
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StakeAddressRequirements era
 -> RIO e (StakeAddressRequirements era))
-> StakeAddressRequirements era
-> RIO e (StakeAddressRequirements era)
forall a b. (a -> b) -> a -> b
$ ConwayEraOnwards era
-> Coin -> StakeCredential -> StakeAddressRequirements era
forall era.
ConwayEraOnwards era
-> Coin -> StakeCredential -> StakeAddressRequirements era
StakeAddrRegistrationConway ConwayEraOnwards era
ceo Coin
dep StakeCredential
stakeCred
    )
    ShelleyBasedEra era
sbe

runStakeAddressStakeDelegationCertificateCmd
  :: ()
  => ShelleyBasedEra era
  -> StakeIdentifier
  -- ^ Delegator stake verification key, verification key file or script file.
  -> StakePoolKeyHashSource
  -- ^ Delegatee stake pool verification key or verification key file or
  -- verification key hash.
  -> File () Out
  -> CIO e ()
runStakeAddressStakeDelegationCertificateCmd :: forall era e.
ShelleyBasedEra era
-> StakeIdentifier
-> StakePoolKeyHashSource
-> File () 'Out
-> CIO e ()
runStakeAddressStakeDelegationCertificateCmd ShelleyBasedEra era
sbe StakeIdentifier
stakeVerifier StakePoolKeyHashSource
poolVKeyOrHashOrFile File () 'Out
outFp =
  ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => RIO e ()) -> RIO e ()
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era => RIO e ()) -> RIO e ())
-> (ShelleyBasedEraConstraints era => RIO e ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ do
    Hash StakePoolKey
poolStakeVKeyHash <- StakePoolKeyHashSource -> RIO e (Hash StakePoolKey)
forall (m :: * -> *).
MonadIO m =>
StakePoolKeyHashSource -> m (Hash StakePoolKey)
getHashFromStakePoolKeyHashSource StakePoolKeyHashSource
poolVKeyOrHashOrFile

    StakeCredential
stakeCred <- StakeIdentifier -> CIO e StakeCredential
forall e. StakeIdentifier -> CIO e StakeCredential
getStakeCredentialFromIdentifier StakeIdentifier
stakeVerifier

    let certificate :: Certificate era
certificate =
          ShelleyBasedEra era
-> StakeCredential -> Hash StakePoolKey -> Certificate era
forall era.
ShelleyBasedEra era
-> StakeCredential -> Hash StakePoolKey -> Certificate era
createStakeDelegationCertificate ShelleyBasedEra era
sbe StakeCredential
stakeCred Hash StakePoolKey
poolStakeVKeyHash

    forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli @(FileError ()) (IO (Either (FileError ()) ()) -> RIO e ())
-> IO (Either (FileError ()) ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$
      File () 'Out -> ByteString -> IO (Either (FileError ()) ())
forall (m :: * -> *) content e.
MonadIO m =>
File content 'Out -> ByteString -> m (Either (FileError e) ())
writeLazyByteStringFile File () 'Out
outFp (ByteString -> IO (Either (FileError ()) ()))
-> ByteString -> IO (Either (FileError ()) ())
forall a b. (a -> b) -> a -> b
$
        Maybe TextEnvelopeDescr -> Certificate era -> ByteString
forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> ByteString
textEnvelopeToJSON (forall a. a -> Maybe a
Just @TextEnvelopeDescr TextEnvelopeDescr
"Stake Delegation Certificate") Certificate era
certificate

createStakeDelegationCertificate
  :: ShelleyBasedEra era
  -> StakeCredential
  -> Hash StakePoolKey
  -> Certificate era
createStakeDelegationCertificate :: forall era.
ShelleyBasedEra era
-> StakeCredential -> Hash StakePoolKey -> Certificate era
createStakeDelegationCertificate ShelleyBasedEra era
sbe StakeCredential
stakeCredential Hash StakePoolKey
stakePoolHash = do
  (ShelleyToBabbageEraConstraints era =>
 ShelleyToBabbageEra era -> Certificate era)
-> (ConwayEraOnwardsConstraints era =>
    ConwayEraOnwards era -> Certificate era)
-> ShelleyBasedEra era
-> Certificate era
forall era a.
(ShelleyToBabbageEraConstraints era =>
 ShelleyToBabbageEra era -> a)
-> (ConwayEraOnwardsConstraints era => ConwayEraOnwards era -> a)
-> ShelleyBasedEra era
-> a
caseShelleyToBabbageOrConwayEraOnwards
    ( \ShelleyToBabbageEra era
w ->
        ShelleyToBabbageEra era
-> (ShelleyToBabbageEraConstraints era => Certificate era)
-> Certificate era
forall era a.
ShelleyToBabbageEra era
-> (ShelleyToBabbageEraConstraints era => a) -> a
shelleyToBabbageEraConstraints ShelleyToBabbageEra era
w ((ShelleyToBabbageEraConstraints era => Certificate era)
 -> Certificate era)
-> (ShelleyToBabbageEraConstraints era => Certificate era)
-> Certificate era
forall a b. (a -> b) -> a -> b
$
          ShelleyToBabbageEra era
-> ShelleyTxCert (ShelleyLedgerEra era) -> Certificate era
forall era.
Typeable era =>
ShelleyToBabbageEra era
-> ShelleyTxCert (ShelleyLedgerEra era) -> Certificate era
ShelleyRelatedCertificate ShelleyToBabbageEra era
w (ShelleyTxCert (ShelleyLedgerEra era) -> Certificate era)
-> ShelleyTxCert (ShelleyLedgerEra era) -> Certificate era
forall a b. (a -> b) -> a -> b
$
            StakeCredential
-> KeyHash 'StakePool -> TxCert (ShelleyLedgerEra era)
forall era.
ShelleyEraTxCert era =>
StakeCredential -> KeyHash 'StakePool -> TxCert era
L.mkDelegStakeTxCert (StakeCredential -> StakeCredential
toShelleyStakeCredential StakeCredential
stakeCredential) (Hash StakePoolKey -> KeyHash 'StakePool
toLedgerHash Hash StakePoolKey
stakePoolHash)
    )
    ( \ConwayEraOnwards era
w ->
        ConwayEraOnwards era
-> (ConwayEraOnwardsConstraints era => Certificate era)
-> Certificate era
forall era a.
ConwayEraOnwards era -> (ConwayEraOnwardsConstraints era => a) -> a
conwayEraOnwardsConstraints ConwayEraOnwards era
w ((ConwayEraOnwardsConstraints era => Certificate era)
 -> Certificate era)
-> (ConwayEraOnwardsConstraints era => Certificate era)
-> Certificate era
forall a b. (a -> b) -> a -> b
$
          ConwayEraOnwards era
-> ConwayTxCert (ShelleyLedgerEra era) -> Certificate era
forall era.
Typeable era =>
ConwayEraOnwards era
-> ConwayTxCert (ShelleyLedgerEra era) -> Certificate era
ConwayCertificate ConwayEraOnwards era
w (ConwayTxCert (ShelleyLedgerEra era) -> Certificate era)
-> ConwayTxCert (ShelleyLedgerEra era) -> Certificate era
forall a b. (a -> b) -> a -> b
$
            StakeCredential -> Delegatee -> TxCert (ShelleyLedgerEra era)
forall era.
ConwayEraTxCert era =>
StakeCredential -> Delegatee -> TxCert era
L.mkDelegTxCert
              (StakeCredential -> StakeCredential
toShelleyStakeCredential StakeCredential
stakeCredential)
              (KeyHash 'StakePool -> Delegatee
L.DelegStake (Hash StakePoolKey -> KeyHash 'StakePool
toLedgerHash Hash StakePoolKey
stakePoolHash))
    )
    ShelleyBasedEra era
sbe
 where
  toLedgerHash :: Hash StakePoolKey -> L.KeyHash L.StakePool
  toLedgerHash :: Hash StakePoolKey -> KeyHash 'StakePool
toLedgerHash (StakePoolKeyHash KeyHash 'StakePool
poolStakeVKeyHash) = KeyHash 'StakePool
poolStakeVKeyHash