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

module Cardano.CLI.EraBased.StakePool.Run
  ( runStakePoolCmds
  , runStakePoolIdCmd
  , runStakePoolMetadataHashCmd
  , runStakePoolRegistrationCertificateCmd
  , runStakePoolBlsRegistrationCertificateCmd
  , runStakePoolDeregistrationCertificateCmd
  )
where

import Cardano.Api
import Cardano.Api.Experimental
import Cardano.Api.Experimental.Certificate
  ( StakePoolMetadata
  , StakePoolParameters (..)
  , toShelleyPoolParams
  , validateAndHashStakePoolMetadata
  )
import Cardano.Api.Ledger qualified as L

import Cardano.CLI.Compatible.Exception
import Cardano.CLI.EraBased.StakePool.Command
import Cardano.CLI.EraBased.StakePool.Command qualified as Cmd
import Cardano.CLI.EraBased.StakePool.Internal.Metadata (carryHashChecks)
import Cardano.CLI.EraBased.StakePool.Internal.Relay (validateStakePoolRelays)
import Cardano.CLI.EraIndependent.Hash.Command qualified as Cmd
import Cardano.CLI.EraIndependent.Hash.Internal.Common
  ( allSchemes
  , getByteStringFromURL
  )
import Cardano.CLI.Helper (printWarning)
import Cardano.CLI.Orphan ()
import Cardano.CLI.Read (getVerificationKeyFromStakePoolVerificationKeySource)
import Cardano.CLI.Type.Common
import Cardano.CLI.Type.Error.HashCmdError (FetchURLError (..))
import Cardano.CLI.Type.Error.StakePoolCmdError
import Cardano.CLI.Type.Key (readVerificationKeyOrFile)

import Control.Monad (forM, when)
import Data.ByteString.Char8 qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Function ((&))
import Data.Text qualified as T
import Data.Text.Encoding qualified as Text
import Data.Text.IO qualified as T
import System.IO (stderr)
import Vary qualified

registrationCertDesc :: TextEnvelopeDescr
registrationCertDesc :: TextEnvelopeDescr
registrationCertDesc = TextEnvelopeDescr
"Stake Pool Registration Certificate"

runStakePoolCmds
  :: IsEra era
  => StakePoolCmds era
  -> CIO e ()
runStakePoolCmds :: forall era e. IsEra era => StakePoolCmds era -> CIO e ()
runStakePoolCmds = \case
  StakePoolBlsRegistrationCertificateCmd StakePoolBlsRegistrationCertificateCmdArgs era
args -> StakePoolBlsRegistrationCertificateCmdArgs era -> CIO e ()
forall era e.
IsEra era =>
StakePoolBlsRegistrationCertificateCmdArgs era -> CIO e ()
runStakePoolBlsRegistrationCertificateCmd StakePoolBlsRegistrationCertificateCmdArgs era
args
  StakePoolDeregistrationCertificateCmd StakePoolDeregistrationCertificateCmdArgs era
args -> StakePoolDeregistrationCertificateCmdArgs era -> CIO e ()
forall era e.
StakePoolDeregistrationCertificateCmdArgs era -> CIO e ()
runStakePoolDeregistrationCertificateCmd StakePoolDeregistrationCertificateCmdArgs era
args
  StakePoolIdCmd StakePoolIdCmdArgs era
args -> StakePoolIdCmdArgs era -> CIO e ()
forall era e. StakePoolIdCmdArgs era -> CIO e ()
runStakePoolIdCmd StakePoolIdCmdArgs era
args
  StakePoolMetadataHashCmd StakePoolMetadataHashCmdArgs era
args -> StakePoolMetadataHashCmdArgs era -> CIO e ()
forall era e. StakePoolMetadataHashCmdArgs era -> CIO e ()
runStakePoolMetadataHashCmd StakePoolMetadataHashCmdArgs era
args
  StakePoolRegistrationCertificateCmd StakePoolRegistrationCertificateCmdArgs era
args -> StakePoolRegistrationCertificateCmdArgs era -> CIO e ()
forall era e.
IsEra era =>
StakePoolRegistrationCertificateCmdArgs era -> CIO e ()
runStakePoolRegistrationCertificateCmd StakePoolRegistrationCertificateCmdArgs era
args

--
-- Stake pool command implementations
--

-- | Create a stake pool registration cert.
-- TODO: Metadata and more stake pool relay support to be
-- added in the future.
runStakePoolRegistrationCertificateCmd
  :: forall era e
   . IsEra era
  => StakePoolRegistrationCertificateCmdArgs era
  -> CIO e ()
runStakePoolRegistrationCertificateCmd :: forall era e.
IsEra era =>
StakePoolRegistrationCertificateCmdArgs era -> CIO e ()
runStakePoolRegistrationCertificateCmd
  Cmd.StakePoolRegistrationCertificateCmdArgs
    { Era era
era :: Era era
era :: forall era. StakePoolRegistrationCertificateCmdArgs era -> Era era
era
    , StakePoolVerificationKeySource
poolVerificationKeyOrFile :: StakePoolVerificationKeySource
poolVerificationKeyOrFile :: forall era.
StakePoolRegistrationCertificateCmdArgs era
-> StakePoolVerificationKeySource
poolVerificationKeyOrFile
    , VerificationKeyOrFile VrfKey
vrfVerificationKeyOrFile :: VerificationKeyOrFile VrfKey
vrfVerificationKeyOrFile :: forall era.
StakePoolRegistrationCertificateCmdArgs era
-> VerificationKeyOrFile VrfKey
vrfVerificationKeyOrFile
    , Maybe (SigningKeyFile 'In)
blsSkeyFile :: Maybe (SigningKeyFile 'In)
blsSkeyFile :: forall era.
StakePoolRegistrationCertificateCmdArgs era
-> Maybe (SigningKeyFile 'In)
blsSkeyFile
    , Coin
poolPledge :: Coin
poolPledge :: forall era. StakePoolRegistrationCertificateCmdArgs era -> Coin
poolPledge
    , Coin
poolCost :: Coin
poolCost :: forall era. StakePoolRegistrationCertificateCmdArgs era -> Coin
poolCost
    , Rational
poolMargin :: Rational
poolMargin :: forall era. StakePoolRegistrationCertificateCmdArgs era -> Rational
poolMargin
    , VerificationKeyOrFile StakeKey
rewardStakeVerificationKeyOrFile :: VerificationKeyOrFile StakeKey
rewardStakeVerificationKeyOrFile :: forall era.
StakePoolRegistrationCertificateCmdArgs era
-> VerificationKeyOrFile StakeKey
rewardStakeVerificationKeyOrFile
    , [VerificationKeyOrFile StakeKey]
ownerStakeVerificationKeyOrFiles :: [VerificationKeyOrFile StakeKey]
ownerStakeVerificationKeyOrFiles :: forall era.
StakePoolRegistrationCertificateCmdArgs era
-> [VerificationKeyOrFile StakeKey]
ownerStakeVerificationKeyOrFiles
    , [StakePoolRelay]
relays :: [StakePoolRelay]
relays :: forall era.
StakePoolRegistrationCertificateCmdArgs era -> [StakePoolRelay]
relays
    , ValidateRelays
validateRelays :: ValidateRelays
validateRelays :: forall era.
StakePoolRegistrationCertificateCmdArgs era -> ValidateRelays
validateRelays
    , Maybe
  (PotentiallyCheckedAnchor
     StakePoolMetadataReference StakePoolMetadataReference)
mMetadata :: Maybe
  (PotentiallyCheckedAnchor
     StakePoolMetadataReference StakePoolMetadataReference)
mMetadata :: forall era.
StakePoolRegistrationCertificateCmdArgs era
-> Maybe
     (PotentiallyCheckedAnchor
        StakePoolMetadataReference StakePoolMetadataReference)
mMetadata
    , NetworkId
network :: NetworkId
network :: forall era.
StakePoolRegistrationCertificateCmdArgs era -> NetworkId
network
    , File () 'Out
outFile :: File () 'Out
outFile :: forall era.
StakePoolRegistrationCertificateCmdArgs era -> File () 'Out
outFile
    } =
    Era era -> (EraCommonConstraints era => RIO e ()) -> RIO e ()
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => RIO e ()) -> RIO e ())
-> (EraCommonConstraints era => RIO e ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ do
      Bool -> RIO e () -> RIO e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ValidateRelays
validateRelays ValidateRelays -> ValidateRelays -> Bool
forall a. Eq a => a -> a -> Bool
== ValidateRelays
ValidateRelays) (RIO e () -> RIO e ()) -> RIO e () -> RIO e ()
forall a b. (a -> b) -> a -> b
$
        NetworkId -> [StakePoolRelay] -> CIO e ()
forall e. NetworkId -> [StakePoolRelay] -> CIO e ()
validateStakePoolRelays NetworkId
network [StakePoolRelay]
relays

      -- 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 <-
        mapM
          readVerificationKeyOrFile
          ownerStakeVerificationKeyOrFiles
      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

      -- BLS voting key, registered from Dijkstra onwards
      mBlsKey <-
        forM blsSkeyFile $ \SigningKeyFile 'In
skeyFile -> do
          blsSkey <-
            forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli @(FileError TextEnvelopeError) (IO (Either (FileError TextEnvelopeError) (SigningKey BlsKey))
 -> RIO e (SigningKey BlsKey))
-> IO (Either (FileError TextEnvelopeError) (SigningKey BlsKey))
-> RIO e (SigningKey BlsKey)
forall a b. (a -> b) -> a -> b
$
              forall a content.
HasTextEnvelope a =>
File content 'In -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope @(SigningKey BlsKey) SigningKeyFile 'In
skeyFile
          pure $ toLedgerBlsKey blsSkey

      let stakePoolParams =
            StakePoolParameters
              { stakePoolId :: Hash StakePoolKey
stakePoolId = Hash StakePoolKey
stakePoolId'
              , stakePoolVRF :: Hash VrfKey
stakePoolVRF = Hash VrfKey
vrfKeyHash'
              , stakePoolBlsKey :: Maybe BlsKey
stakePoolBlsKey = Maybe BlsKey
mBlsKey
              , 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 -> StakePoolParams (LedgerEra era)
forall era. StakePoolParameters -> StakePoolParams era
toShelleyPoolParams StakePoolParameters
stakePoolParams
          registrationCert = StakePoolParams (LedgerEra era) -> Certificate (LedgerEra era)
forall era.
IsEra era =>
StakePoolParams (LedgerEra era) -> Certificate (LedgerEra era)
makeStakePoolRegistrationCertificate StakePoolParams (LedgerEra era)
ledgerStakePoolParams :: Certificate (LedgerEra era)

      mapM_ (fromExceptTCli . carryHashChecks) mMetadata
      fromEitherIOCli @(FileError ()) $
        writeLazyByteStringFile outFile $
          textEnvelopeToJSON (Just registrationCertDesc) registrationCert

-- | Create a stake pool registration certificate that keeps every parameter of
-- an existing one and replaces only its BLS key.
runStakePoolBlsRegistrationCertificateCmd
  :: forall era e
   . IsEra era
  => StakePoolBlsRegistrationCertificateCmdArgs era
  -> CIO e ()
runStakePoolBlsRegistrationCertificateCmd :: forall era e.
IsEra era =>
StakePoolBlsRegistrationCertificateCmdArgs era -> CIO e ()
runStakePoolBlsRegistrationCertificateCmd
  Cmd.StakePoolBlsRegistrationCertificateCmdArgs
    { Era era
era :: Era era
era :: forall era.
StakePoolBlsRegistrationCertificateCmdArgs era -> Era era
era
    , poolParametersSource :: forall era.
StakePoolBlsRegistrationCertificateCmdArgs era
-> StakePoolParametersSource
poolParametersSource = StakePoolParametersFromCertificate (CertificateFile String
certFile)
    , SigningKeyFile 'In
blsSkeyFile :: SigningKeyFile 'In
blsSkeyFile :: forall era.
StakePoolBlsRegistrationCertificateCmdArgs era
-> SigningKeyFile 'In
blsSkeyFile
    , File () 'Out
outFile :: File () 'Out
outFile :: forall era.
StakePoolBlsRegistrationCertificateCmdArgs era -> File () 'Out
outFile
    } =
    Era era -> (EraCommonConstraints era => RIO e ()) -> RIO e ()
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => RIO e ()) -> RIO e ())
-> (EraCommonConstraints era => RIO e ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ do
      Certificate cert <-
        forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli @(FileError TextEnvelopeError) (IO
   (Either
      (FileError TextEnvelopeError) (Certificate (LedgerEra era)))
 -> RIO e (Certificate (LedgerEra era)))
-> IO
     (Either
        (FileError TextEnvelopeError) (Certificate (LedgerEra era)))
-> RIO e (Certificate (LedgerEra era))
forall a b. (a -> b) -> a -> b
$
          forall a content.
HasTextEnvelope a =>
File content 'In -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope @(Certificate (LedgerEra era)) (String -> File (ZonkAny 0) 'In
forall content (direction :: FileDirection).
String -> File content direction
File String
certFile)
      oldParams <-
        fromMaybeCli (StakePoolCmdNotRegistrationCertificateError certFile) $
          L.getRegPoolTxCert cert

      blsSkey <-
        fromEitherIOCli @(FileError TextEnvelopeError) $
          readFileTextEnvelope @(SigningKey BlsKey) blsSkeyFile
      let newBlsKey = SigningKey BlsKey -> BlsKey
toLedgerBlsKey SigningKey BlsKey
blsSkey
          mOldBlsKey = StrictMaybe BlsKey -> Maybe BlsKey
forall a. StrictMaybe a -> Maybe a
L.strictMaybeToMaybe (StrictMaybe BlsKey -> Maybe BlsKey)
-> StrictMaybe BlsKey -> Maybe BlsKey
forall a b. (a -> b) -> a -> b
$ StakePoolParams (LedgerEra era) -> StrictMaybe BlsKey
forall era. StakePoolParams era -> StrictMaybe BlsKey
L.sppBlsKey StakePoolParams (LedgerEra era)
oldParams
          newParams = StakePoolParams (LedgerEra era)
oldParams{L.sppBlsKey = L.SJust newBlsKey}
          registrationCert = StakePoolParams (LedgerEra era) -> Certificate (LedgerEra era)
forall era.
IsEra era =>
StakePoolParams (LedgerEra era) -> Certificate (LedgerEra era)
makeStakePoolRegistrationCertificate StakePoolParams (LedgerEra era)
newParams :: Certificate (LedgerEra era)

      liftIO $ do
        T.hPutStrLn stderr $ "Pool ID: " <> serialiseToBech32 (StakePoolKeyHash $ L.sppId oldParams)
        T.hPutStrLn stderr $ "Old BLS key: " <> maybe "none (first registration)" renderBlsKey mOldBlsKey
        T.hPutStrLn stderr $ "New BLS key: " <> renderBlsKey newBlsKey
      when (mOldBlsKey == Just newBlsKey) $
        printWarning "The new BLS key is the same as the registered one."

      fromEitherIOCli @(FileError ()) $
        writeLazyByteStringFile outFile $
          textEnvelopeToJSON (Just registrationCertDesc) registrationCert
   where
    renderBlsKey :: L.BlsKey -> T.Text
    renderBlsKey :: BlsKey -> Text
renderBlsKey = VerificationKey BlsKey -> Text
forall a. SerialiseAsBech32 a => a -> Text
serialiseToBech32 (VerificationKey BlsKey -> Text)
-> (BlsKey -> VerificationKey BlsKey) -> BlsKey -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerKeyDSIGN BLS12381MinSigDSIGN -> VerificationKey BlsKey
BlsVerificationKey (VerKeyDSIGN BLS12381MinSigDSIGN -> VerificationKey BlsKey)
-> (BlsKey -> VerKeyDSIGN BLS12381MinSigDSIGN)
-> BlsKey
-> VerificationKey BlsKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlsKey -> VerKeyDSIGN BLS12381MinSigDSIGN
L.blsPubKey

runStakePoolDeregistrationCertificateCmd
  :: forall era e
   . StakePoolDeregistrationCertificateCmdArgs era
  -> CIO e ()
runStakePoolDeregistrationCertificateCmd :: forall era e.
StakePoolDeregistrationCertificateCmdArgs era -> CIO e ()
runStakePoolDeregistrationCertificateCmd
  Cmd.StakePoolDeregistrationCertificateCmdArgs
    { Era era
era :: Era era
era :: forall era.
StakePoolDeregistrationCertificateCmdArgs era -> Era era
era
    , StakePoolVerificationKeySource
poolVerificationKeyOrFile :: StakePoolVerificationKeySource
poolVerificationKeyOrFile :: forall era.
StakePoolDeregistrationCertificateCmdArgs era
-> StakePoolVerificationKeySource
poolVerificationKeyOrFile
    , EpochNo
retireEpoch :: EpochNo
retireEpoch :: forall era.
StakePoolDeregistrationCertificateCmdArgs era -> EpochNo
retireEpoch
    , File () 'Out
outFile :: File () 'Out
outFile :: forall era.
StakePoolDeregistrationCertificateCmdArgs era -> File () 'Out
outFile
    } =
    Era era -> (EraCommonConstraints era => RIO e ()) -> RIO e ()
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints Era era
era ((EraCommonConstraints era => RIO e ()) -> RIO e ())
-> (EraCommonConstraints 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
          retireCert =
            Hash StakePoolKey -> EpochNo -> Certificate (ShelleyLedgerEra era)
forall era.
IsShelleyBasedEra era =>
Hash StakePoolKey -> EpochNo -> Certificate (ShelleyLedgerEra era)
makeStakePoolRetirementCertificate Hash StakePoolKey
stakePoolId' EpochNo
retireEpoch :: Certificate (ShelleyLedgerEra era)

      fromEitherIOCli @(FileError ()) $
        writeLazyByteStringFile outFile $
          textEnvelopeToJSON (Just retireCertDesc) retireCert
   where
    retireCertDesc :: TextEnvelopeDescr
    retireCertDesc :: TextEnvelopeDescr
retireCertDesc = TextEnvelopeDescr
"Stake Pool Retirement Certificate"

runStakePoolIdCmd
  :: ()
  => StakePoolIdCmdArgs era
  -> CIO e ()
runStakePoolIdCmd :: forall era e. StakePoolIdCmdArgs era -> CIO e ()
runStakePoolIdCmd
  Cmd.StakePoolIdCmdArgs
    { StakePoolVerificationKeySource
poolVerificationKeyOrFile :: StakePoolVerificationKeySource
poolVerificationKeyOrFile :: forall era.
StakePoolIdCmdArgs era -> StakePoolVerificationKeySource
poolVerificationKeyOrFile
    , Vary '[FormatBech32, FormatHex]
outputFormat :: Vary '[FormatBech32, FormatHex]
outputFormat :: forall era.
StakePoolIdCmdArgs era -> Vary '[FormatBech32, FormatHex]
outputFormat
    , Maybe (File () 'Out)
mOutFile :: Maybe (File () 'Out)
mOutFile :: forall era. StakePoolIdCmdArgs era -> Maybe (File () 'Out)
mOutFile
    } = do
    stakePoolVerKey <- StakePoolVerificationKeySource -> RIO e AnyStakePoolVerificationKey
forall (m :: * -> *).
MonadIO m =>
StakePoolVerificationKeySource -> m AnyStakePoolVerificationKey
getVerificationKeyFromStakePoolVerificationKeySource StakePoolVerificationKeySource
poolVerificationKeyOrFile
    let stakePoolKeyHash = AnyStakePoolVerificationKey -> Hash StakePoolKey
anyStakePoolVerificationKeyHash AnyStakePoolVerificationKey
stakePoolVerKey

    let output =
          Vary '[FormatBech32, FormatHex]
outputFormat
            Vary '[FormatBech32, FormatHex]
-> (Vary '[FormatBech32, FormatHex]
    -> Hash StakePoolKey -> ByteString)
-> Hash StakePoolKey
-> ByteString
forall a b. a -> (a -> b) -> b
& ( (Vary '[FormatBech32, FormatHex]
 -> Hash StakePoolKey -> ByteString)
-> Vary '[FormatBech32, FormatHex]
-> Hash StakePoolKey
-> ByteString
forall a. a -> a
id
                  ((Vary '[FormatBech32, FormatHex]
  -> Hash StakePoolKey -> ByteString)
 -> Vary '[FormatBech32, FormatHex]
 -> Hash StakePoolKey
 -> ByteString)
-> ((Vary '[] -> Hash StakePoolKey -> ByteString)
    -> Vary '[FormatBech32, FormatHex]
    -> Hash StakePoolKey
    -> ByteString)
-> (Vary '[] -> Hash StakePoolKey -> ByteString)
-> Vary '[FormatBech32, FormatHex]
-> Hash StakePoolKey
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FormatBech32 -> Hash StakePoolKey -> ByteString)
-> (Vary '[FormatHex] -> Hash StakePoolKey -> ByteString)
-> Vary '[FormatBech32, FormatHex]
-> Hash StakePoolKey
-> ByteString
forall a b (l :: [*]).
(a -> b) -> (Vary l -> b) -> Vary (a : l) -> b
Vary.on (\FormatBech32
FormatBech32 -> Text -> ByteString
Text.encodeUtf8 (Text -> ByteString)
-> (Hash StakePoolKey -> Text) -> Hash StakePoolKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash StakePoolKey -> Text
forall a. SerialiseAsBech32 a => a -> Text
serialiseToBech32)
                  ((Vary '[FormatHex] -> Hash StakePoolKey -> ByteString)
 -> Vary '[FormatBech32, FormatHex]
 -> Hash StakePoolKey
 -> ByteString)
-> ((Vary '[] -> Hash StakePoolKey -> ByteString)
    -> Vary '[FormatHex] -> Hash StakePoolKey -> ByteString)
-> (Vary '[] -> Hash StakePoolKey -> ByteString)
-> Vary '[FormatBech32, FormatHex]
-> Hash StakePoolKey
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FormatHex -> Hash StakePoolKey -> ByteString)
-> (Vary '[] -> Hash StakePoolKey -> ByteString)
-> Vary '[FormatHex]
-> Hash StakePoolKey
-> ByteString
forall a b (l :: [*]).
(a -> b) -> (Vary l -> b) -> Vary (a : l) -> b
Vary.on (\FormatHex
FormatHex -> Hash StakePoolKey -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytesHex)
                  ((Vary '[] -> Hash StakePoolKey -> ByteString)
 -> Vary '[FormatBech32, FormatHex]
 -> Hash StakePoolKey
 -> ByteString)
-> (Vary '[] -> Hash StakePoolKey -> ByteString)
-> Vary '[FormatBech32, FormatHex]
-> Hash StakePoolKey
-> ByteString
forall a b. (a -> b) -> a -> b
$ Vary '[] -> Hash StakePoolKey -> ByteString
forall anything. Vary '[] -> anything
Vary.exhaustiveCase
              )
            (Hash StakePoolKey -> ByteString)
-> Hash StakePoolKey -> ByteString
forall a b. (a -> b) -> a -> b
$ Hash StakePoolKey
stakePoolKeyHash

    fromEitherIOCli @(FileError ()) $
      writeByteStringOutput mOutFile output

runStakePoolMetadataHashCmd
  :: ()
  => StakePoolMetadataHashCmdArgs era
  -> CIO e ()
runStakePoolMetadataHashCmd :: forall era e. StakePoolMetadataHashCmdArgs era -> CIO e ()
runStakePoolMetadataHashCmd
  Cmd.StakePoolMetadataHashCmdArgs
    { StakePoolMetadataSource
poolMetadataSource :: StakePoolMetadataSource
poolMetadataSource :: forall era.
StakePoolMetadataHashCmdArgs era -> StakePoolMetadataSource
poolMetadataSource
    , HashGoal (Hash StakePoolMetadata)
hashGoal :: HashGoal (Hash StakePoolMetadata)
hashGoal :: forall era.
StakePoolMetadataHashCmdArgs era
-> HashGoal (Hash StakePoolMetadata)
hashGoal
    } = do
    metadataBytes <-
      case StakePoolMetadataSource
poolMetadataSource of
        StakePoolMetadataFileIn StakePoolMetadataFile 'In
poolMetadataFile ->
          forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
IO (Either e a) -> m a
fromEitherIOCli @(FileError ()) (IO (Either (FileError ()) ByteString) -> RIO e ByteString)
-> IO (Either (FileError ()) ByteString) -> RIO e ByteString
forall a b. (a -> b) -> a -> b
$
            StakePoolMetadataFile 'In -> IO (Either (FileError ()) ByteString)
forall (m :: * -> *) content e.
MonadIO m =>
File content 'In -> m (Either (FileError e) ByteString)
readByteStringFile StakePoolMetadataFile 'In
poolMetadataFile
        StakePoolMetadataURL Url
urlText ->
          ExceptT StakePoolCmdError IO ByteString -> RIO e ByteString
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
ExceptT e IO a -> m a
fromExceptTCli (ExceptT StakePoolCmdError IO ByteString -> RIO e ByteString)
-> (ExceptT FetchURLError IO ByteString
    -> ExceptT StakePoolCmdError IO ByteString)
-> ExceptT FetchURLError IO ByteString
-> RIO e ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT FetchURLError IO ByteString
-> ExceptT StakePoolCmdError IO ByteString
fetchURLToStakePoolCmdError (ExceptT FetchURLError IO ByteString -> RIO e ByteString)
-> ExceptT FetchURLError IO ByteString -> RIO e ByteString
forall a b. (a -> b) -> a -> b
$ SupportedSchemes -> Text -> ExceptT FetchURLError IO ByteString
getByteStringFromURL SupportedSchemes
allSchemes (Text -> ExceptT FetchURLError IO ByteString)
-> Text -> ExceptT FetchURLError IO ByteString
forall a b. (a -> b) -> a -> b
$ Url -> Text
L.urlToText Url
urlText

    (_metadata, metadataHash) <-
      fromEitherCli $
        validateAndHashStakePoolMetadata metadataBytes

    case hashGoal of
      Cmd.CheckHash Hash StakePoolMetadata
expectedHash
        | Hash StakePoolMetadata
metadataHash Hash StakePoolMetadata -> Hash StakePoolMetadata -> Bool
forall a. Eq a => a -> a -> Bool
/= Hash StakePoolMetadata
expectedHash ->
            StakePoolCmdError -> RIO e ()
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError (StakePoolCmdError -> RIO e ()) -> StakePoolCmdError -> RIO e ()
forall a b. (a -> b) -> a -> b
$ Hash StakePoolMetadata
-> Hash StakePoolMetadata -> StakePoolCmdError
StakePoolCmdHashMismatchError Hash StakePoolMetadata
expectedHash Hash StakePoolMetadata
metadataHash
        | Bool
otherwise -> IO () -> RIO e ()
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO e ()) -> IO () -> RIO e ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Hashes match!"
      Cmd.HashToFile File () 'Out
outFile -> Maybe (File () 'Out) -> Hash StakePoolMetadata -> CIO e ()
forall e.
Maybe (File () 'Out) -> Hash StakePoolMetadata -> CIO e ()
writeOutput (File () 'Out -> Maybe (File () 'Out)
forall a. a -> Maybe a
Just File () 'Out
outFile) Hash StakePoolMetadata
metadataHash
      HashGoal (Hash StakePoolMetadata)
Cmd.HashToStdout -> Maybe (File () 'Out) -> Hash StakePoolMetadata -> CIO e ()
forall e.
Maybe (File () 'Out) -> Hash StakePoolMetadata -> CIO e ()
writeOutput Maybe (File () 'Out)
forall a. Maybe a
Nothing Hash StakePoolMetadata
metadataHash
   where
    writeOutput :: Maybe (File () Out) -> Hash StakePoolMetadata -> CIO e ()
    writeOutput :: forall e.
Maybe (File () 'Out) -> Hash StakePoolMetadata -> CIO e ()
writeOutput Maybe (File () 'Out)
mOutFile Hash StakePoolMetadata
metadataHash = do
      let output :: ByteString
output = ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Hash StakePoolMetadata -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytesHex Hash StakePoolMetadata
metadataHash

      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
$
        Maybe (File () 'Out) -> ByteString -> IO (Either (FileError ()) ())
forall (m :: * -> *) content e.
MonadIO m =>
Maybe (File content 'Out)
-> ByteString -> m (Either (FileError e) ())
writeLazyByteStringOutput Maybe (File () 'Out)
mOutFile ByteString
output

    fetchURLToStakePoolCmdError
      :: ExceptT FetchURLError IO BS.ByteString -> ExceptT StakePoolCmdError IO BS.ByteString
    fetchURLToStakePoolCmdError :: ExceptT FetchURLError IO ByteString
-> ExceptT StakePoolCmdError IO ByteString
fetchURLToStakePoolCmdError = (FetchURLError -> StakePoolCmdError)
-> ExceptT FetchURLError IO ByteString
-> ExceptT StakePoolCmdError IO ByteString
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT FetchURLError -> StakePoolCmdError
StakePoolCmdFetchURLError