{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.CLI.Compatible.StakePool.Run
  ( runCompatibleStakePoolCmds
  )
where

import Cardano.Api hiding (makeStakePoolRegistrationCertificate)
import Cardano.Api.Compatible.Certificate
import Cardano.Api.Experimental qualified as Exp

import Cardano.CLI.Compatible.Exception
import Cardano.CLI.Compatible.StakePool.Command
import Cardano.CLI.EraBased.StakePool.Internal.Metadata
import Cardano.CLI.Read
  ( getVerificationKeyFromStakePoolVerificationKeySource
  )
import Cardano.CLI.Type.Common
import Cardano.CLI.Type.Error.StakePoolCmdError
import Cardano.CLI.Type.Key (readVerificationKeyOrFile)

import Control.Monad

runCompatibleStakePoolCmds
  :: ()
  => CompatibleStakePoolCmds era
  -> CIO e ()
runCompatibleStakePoolCmds :: forall era e. CompatibleStakePoolCmds era -> CIO e ()
runCompatibleStakePoolCmds = \case
  CompatibleStakePoolRegistrationCertificateCmd CompatibleStakePoolRegistrationCertificateCmdArgs era
args -> CompatibleStakePoolRegistrationCertificateCmdArgs era -> CIO e ()
forall era e.
CompatibleStakePoolRegistrationCertificateCmdArgs era -> CIO e ()
runStakePoolRegistrationCertificateCmd CompatibleStakePoolRegistrationCertificateCmdArgs era
args

runStakePoolRegistrationCertificateCmd
  :: ()
  => CompatibleStakePoolRegistrationCertificateCmdArgs era
  -> CIO e ()
runStakePoolRegistrationCertificateCmd :: forall era e.
CompatibleStakePoolRegistrationCertificateCmdArgs era -> CIO e ()
runStakePoolRegistrationCertificateCmd
  CompatibleStakePoolRegistrationCertificateCmdArgs
    { sbe :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era
-> ShelleyBasedEra era
sbe = ShelleyBasedEra era
sbe :: ShelleyBasedEra era
    , StakePoolVerificationKeySource
poolVerificationKeyOrFile :: StakePoolVerificationKeySource
poolVerificationKeyOrFile :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era
-> StakePoolVerificationKeySource
poolVerificationKeyOrFile
    , VerificationKeyOrFile VrfKey
vrfVerificationKeyOrFile :: VerificationKeyOrFile VrfKey
vrfVerificationKeyOrFile :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era
-> VerificationKeyOrFile VrfKey
vrfVerificationKeyOrFile
    , Coin
poolPledge :: Coin
poolPledge :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era -> Coin
poolPledge
    , Coin
poolCost :: Coin
poolCost :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era -> Coin
poolCost
    , Rational
poolMargin :: Rational
poolMargin :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era -> Rational
poolMargin
    , VerificationKeyOrFile StakeKey
rewardStakeVerificationKeyOrFile :: VerificationKeyOrFile StakeKey
rewardStakeVerificationKeyOrFile :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era
-> VerificationKeyOrFile StakeKey
rewardStakeVerificationKeyOrFile
    , [VerificationKeyOrFile StakeKey]
ownerStakeVerificationKeyOrFiles :: [VerificationKeyOrFile StakeKey]
ownerStakeVerificationKeyOrFiles :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era
-> [VerificationKeyOrFile StakeKey]
ownerStakeVerificationKeyOrFiles
    , [StakePoolRelay]
relays :: [StakePoolRelay]
relays :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era
-> [StakePoolRelay]
relays
    , Maybe
  (PotentiallyCheckedAnchor
     StakePoolMetadataReference StakePoolMetadataReference)
mMetadata :: Maybe
  (PotentiallyCheckedAnchor
     StakePoolMetadataReference StakePoolMetadataReference)
mMetadata :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era
-> Maybe
     (PotentiallyCheckedAnchor
        StakePoolMetadataReference StakePoolMetadataReference)
mMetadata
    , NetworkId
network :: NetworkId
network :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era -> NetworkId
network
    , File () 'Out
outFile :: File () 'Out
outFile :: forall era.
CompatibleStakePoolRegistrationCertificateCmdArgs era
-> File () 'Out
outFile
    } =
    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
      -- Pool verification key
      stakePoolVerKey <- StakePoolVerificationKeySource -> RIO e AnyStakePoolVerificationKey
forall (m :: * -> *).
MonadIO m =>
StakePoolVerificationKeySource -> m AnyStakePoolVerificationKey
getVerificationKeyFromStakePoolVerificationKeySource StakePoolVerificationKeySource
poolVerificationKeyOrFile
      let stakePoolId' = AnyStakePoolVerificationKey -> Hash StakePoolKey
anyStakePoolVerificationKeyHash AnyStakePoolVerificationKey
stakePoolVerKey

      -- VRF verification key
      vrfVerKey <-
        readVerificationKeyOrFile vrfVerificationKeyOrFile
      let vrfKeyHash' = VerificationKey VrfKey -> Hash VrfKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey VrfKey
vrfVerKey

      -- Pool reward account
      rwdStakeVerKey <-
        readVerificationKeyOrFile rewardStakeVerificationKeyOrFile
      let stakeCred = Hash StakeKey -> StakeCredential
StakeCredentialByKey (VerificationKey StakeKey -> Hash StakeKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey StakeKey
rwdStakeVerKey)
          rewardAccountAddr = NetworkId -> StakeCredential -> StakeAddress
makeStakeAddress NetworkId
network StakeCredential
stakeCred

      -- Pool owner(s)
      sPoolOwnerVkeys <- forM ownerStakeVerificationKeyOrFiles readVerificationKeyOrFile
      let stakePoolOwners' = (VerificationKey StakeKey -> Hash StakeKey)
-> [VerificationKey StakeKey] -> [Hash StakeKey]
forall a b. (a -> b) -> [a] -> [b]
map VerificationKey StakeKey -> Hash StakeKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash [VerificationKey StakeKey]
sPoolOwnerVkeys

      let stakePoolParams =
            StakePoolParameters
              { stakePoolId :: Hash StakePoolKey
stakePoolId = Hash StakePoolKey
stakePoolId'
              , stakePoolVRF :: Hash VrfKey
stakePoolVRF = Hash VrfKey
vrfKeyHash'
              , stakePoolCost :: Coin
stakePoolCost = Coin
poolCost
              , stakePoolMargin :: Rational
stakePoolMargin = Rational
poolMargin
              , stakePoolRewardAccount :: StakeAddress
stakePoolRewardAccount = StakeAddress
rewardAccountAddr
              , stakePoolPledge :: Coin
stakePoolPledge = Coin
poolPledge
              , stakePoolOwners :: [Hash StakeKey]
stakePoolOwners = [Hash StakeKey]
stakePoolOwners'
              , stakePoolRelays :: [StakePoolRelay]
stakePoolRelays = [StakePoolRelay]
relays
              , stakePoolMetadata :: Maybe StakePoolMetadataReference
stakePoolMetadata = PotentiallyCheckedAnchor
  StakePoolMetadataReference StakePoolMetadataReference
-> StakePoolMetadataReference
forall anchorType anchor.
PotentiallyCheckedAnchor anchorType anchor -> anchor
pcaAnchor (PotentiallyCheckedAnchor
   StakePoolMetadataReference StakePoolMetadataReference
 -> StakePoolMetadataReference)
-> Maybe
     (PotentiallyCheckedAnchor
        StakePoolMetadataReference StakePoolMetadataReference)
-> Maybe StakePoolMetadataReference
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe
  (PotentiallyCheckedAnchor
     StakePoolMetadataReference StakePoolMetadataReference)
mMetadata
              }

      let ledgerStakePoolParams = StakePoolParameters -> PoolParams
toShelleyPoolParams StakePoolParameters
stakePoolParams
          registrationCert =
            PoolParams -> Certificate (ShelleyLedgerEra era)
forall era.
IsShelleyBasedEra era =>
PoolParams -> Certificate (ShelleyLedgerEra era)
makeStakePoolRegistrationCertificate PoolParams
ledgerStakePoolParams
              :: Exp.Certificate (ShelleyLedgerEra era)

      mapM_ (fromExceptTCli . carryHashChecks) mMetadata

      fromExceptTCli
        . firstExceptT StakePoolCmdWriteFileError
        . newExceptT
        . writeLazyByteStringFile outFile
        $ textEnvelopeToJSON (Just registrationCertDesc) registrationCert
   where
    registrationCertDesc :: TextEnvelopeDescr
    registrationCertDesc :: TextEnvelopeDescr
registrationCertDesc = TextEnvelopeDescr
"Stake Pool Registration Certificate"