{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Cardano.CLI.Shelley.Run.Query
  ( DelegationsAndRewards(..)
  , ShelleyQueryCmdError
  , ShelleyQueryCmdLocalStateQueryError (..)
  , renderOpCertIntervalInformation
  , renderShelleyQueryCmdError
  , renderLocalStateQueryError
  , runQueryCmd
  , mergeDelegsAndRewards
  , percentage
  , executeQuery
  ) where

import           Cardano.Prelude
import           Prelude (String, id)

import           Cardano.Api
import qualified Cardano.Api as Api
import           Cardano.Api.Byron
import           Cardano.Api.Orphans ()
import           Cardano.Api.Shelley
import           Cardano.Binary (DecoderError)
import           Cardano.CLI.Environment (EnvSocketError, readEnvSocketPath, renderEnvSocketError)
import           Cardano.CLI.Helpers (HelpersError (..), hushM, pPrintCBOR, renderHelpersError)
import           Cardano.CLI.Shelley.Commands
import           Cardano.CLI.Shelley.Key (InputDecodeError, VerificationKeyOrHashOrFile,
                   readVerificationKeyOrHashOrFile)
import           Cardano.CLI.Shelley.Orphans ()
import qualified Cardano.CLI.Shelley.Output as O
import           Cardano.CLI.Shelley.Run.Genesis (ShelleyGenesisCmdError,
                   readAndDecodeShelleyGenesis)
import           Cardano.CLI.Types
import           Cardano.Crypto.Hash (hashToBytesAsHex)
import qualified Cardano.Crypto.Hash.Blake2b as Blake2b
import qualified Cardano.Crypto.VRF as Crypto
import qualified Cardano.Ledger.Alonzo.PParams as Alonzo
import           Cardano.Ledger.BaseTypes (Seed, UnitInterval)
import           Cardano.Ledger.Coin
import           Cardano.Ledger.Compactible
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Credential as Ledger
import qualified Cardano.Ledger.Crypto as Crypto
import qualified Cardano.Ledger.Era as Era
import qualified Cardano.Ledger.Era as Ledger
import           Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
import           Cardano.Ledger.Shelley.Constraints
import           Cardano.Ledger.Shelley.EpochBoundary
import           Cardano.Ledger.Shelley.LedgerState (DPState (..),
                   EpochState (esLState, esSnapshots), LedgerState (..), NewEpochState (nesEs),
                   PState (_fPParams, _pParams, _retiring))
import qualified Cardano.Ledger.Shelley.PParams as Shelley
import           Cardano.Ledger.Shelley.Scripts ()
import           Cardano.Slotting.EpochInfo (EpochInfo (..), epochInfoSlotToUTCTime, hoistEpochInfo)
import           Control.Monad.Trans.Except (except)
import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistMaybe, left,
                   newExceptT, hoistEither)
import           Data.Aeson.Encode.Pretty (encodePretty)
import           Data.Aeson.Types as Aeson
import           Data.Coerce (coerce)
import           Data.List (nub)
import           Data.Sharing (Interns, Share)
import           Data.Text.Lazy.Builder (toLazyText)
import           Data.Time.Clock

import           Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime (..),
                   SystemStart (..), toRelativeTime)
import           Ouroboros.Consensus.Cardano.Block as Consensus (EraMismatch (..))
-- import qualified Ouroboros.Consensus.Protocol.Praos as Praos
import           Ouroboros.Consensus.Protocol.TPraos
import           Ouroboros.Network.Block (Serialised (..))
import           Ouroboros.Network.Protocol.LocalStateQuery.Type (AcquireFailure (..))
import           Text.Printf (printf)

import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.VMap as VMap
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.IO as T
import qualified Data.Text.IO as Text
import qualified Data.Vector as Vector
import           Formatting.Buildable (build)
import           Numeric (showEFloat)
import qualified Ouroboros.Consensus.HardFork.History as Consensus
import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus
import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus

import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry
import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery
import qualified System.IO as IO


{- HLINT ignore "Reduce duplication" -}
{- HLINT ignore "Use const" -}
{- HLINT ignore "Use let" -}

data ShelleyQueryCmdError
  = ShelleyQueryCmdEnvVarSocketErr !EnvSocketError
  | ShelleyQueryCmdLocalStateQueryError !ShelleyQueryCmdLocalStateQueryError
  | ShelleyQueryCmdWriteFileError !(FileError ())
  | ShelleyQueryCmdHelpersError !HelpersError
  | ShelleyQueryCmdAcquireFailure !AcquireFailure
  | ShelleyQueryCmdEraConsensusModeMismatch !AnyConsensusMode !AnyCardanoEra
  | ShelleyQueryCmdByronEra
  | ShelleyQueryCmdPoolIdError (Hash StakePoolKey)
  | ShelleyQueryCmdEraMismatch !EraMismatch
  | ShelleyQueryCmdUnsupportedMode !AnyConsensusMode
  | ShelleyQueryCmdPastHorizon !Qry.PastHorizonException
  | ShelleyQueryCmdSystemStartUnavailable
  | ShelleyQueryCmdGenesisReadError !ShelleyGenesisCmdError
  | ShelleyQueryCmdLeaderShipError !LeadershipError
  | ShelleyQueryCmdTextEnvelopeReadError !(FileError TextEnvelopeError)
  | ShelleyQueryCmdTextReadError !(FileError InputDecodeError )
  | ShelleyQueryCmdColdKeyReadFileError !(FileError InputDecodeError)
  | ShelleyQueryCmdOpCertCounterReadError !(FileError TextEnvelopeError)
  | ShelleyQueryCmdProtocolStateDecodeFailure !(LBS.ByteString, DecoderError)
  | ShelleyQueryCmdSlotToUtcError Text
  | ShelleyQueryCmdNodeUnknownStakePool
      FilePath
      -- ^ Operational certificate of the unknown stake pool.

  deriving Int -> ShelleyQueryCmdError -> ShowS
[ShelleyQueryCmdError] -> ShowS
ShelleyQueryCmdError -> String
(Int -> ShelleyQueryCmdError -> ShowS)
-> (ShelleyQueryCmdError -> String)
-> ([ShelleyQueryCmdError] -> ShowS)
-> Show ShelleyQueryCmdError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShelleyQueryCmdError] -> ShowS
$cshowList :: [ShelleyQueryCmdError] -> ShowS
show :: ShelleyQueryCmdError -> String
$cshow :: ShelleyQueryCmdError -> String
showsPrec :: Int -> ShelleyQueryCmdError -> ShowS
$cshowsPrec :: Int -> ShelleyQueryCmdError -> ShowS
Show

renderShelleyQueryCmdError :: ShelleyQueryCmdError -> Text
renderShelleyQueryCmdError :: ShelleyQueryCmdError -> Text
renderShelleyQueryCmdError ShelleyQueryCmdError
err =
  case ShelleyQueryCmdError
err of
    ShelleyQueryCmdEnvVarSocketErr EnvSocketError
envSockErr -> EnvSocketError -> Text
renderEnvSocketError EnvSocketError
envSockErr
    ShelleyQueryCmdLocalStateQueryError ShelleyQueryCmdLocalStateQueryError
lsqErr -> ShelleyQueryCmdLocalStateQueryError -> Text
renderLocalStateQueryError ShelleyQueryCmdLocalStateQueryError
lsqErr
    ShelleyQueryCmdWriteFileError FileError ()
fileErr -> String -> Text
Text.pack (FileError () -> String
forall e. Error e => e -> String
displayError FileError ()
fileErr)
    ShelleyQueryCmdHelpersError HelpersError
helpersErr -> HelpersError -> Text
renderHelpersError HelpersError
helpersErr
    ShelleyQueryCmdAcquireFailure AcquireFailure
acquireFail -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ AcquireFailure -> String
forall a b. (Show a, ConvertText String b) => a -> b
show AcquireFailure
acquireFail
    ShelleyQueryCmdError
ShelleyQueryCmdByronEra -> Text
"This query cannot be used for the Byron era"
    ShelleyQueryCmdPoolIdError Hash StakePoolKey
poolId -> Text
"The pool id does not exist: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Hash StakePoolKey -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show Hash StakePoolKey
poolId
    ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode ConsensusMode mode
cMode) (AnyCardanoEra CardanoEra era
era) ->
      Text
"Consensus mode and era mismatch. Consensus mode: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConsensusMode mode -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show ConsensusMode mode
cMode Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      Text
" Era: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CardanoEra era -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show CardanoEra era
era
    ShelleyQueryCmdEraMismatch (EraMismatch Text
ledgerEra Text
queryEra) ->
      Text
"\nAn error mismatch occurred." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nSpecified query era: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
queryEra Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      Text
"\nCurrent ledger era: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ledgerEra
    ShelleyQueryCmdUnsupportedMode AnyConsensusMode
mode -> Text
"Unsupported mode: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AnyConsensusMode -> Text
renderMode AnyConsensusMode
mode
    ShelleyQueryCmdPastHorizon PastHorizonException
e -> Text
"Past horizon: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PastHorizonException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show PastHorizonException
e
    ShelleyQueryCmdError
ShelleyQueryCmdSystemStartUnavailable -> Text
"System start unavailable"
    ShelleyQueryCmdGenesisReadError ShelleyGenesisCmdError
err' -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShelleyGenesisCmdError -> String
forall e. Error e => e -> String
displayError ShelleyGenesisCmdError
err'
    ShelleyQueryCmdLeaderShipError LeadershipError
e -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ LeadershipError -> String
forall e. Error e => e -> String
displayError LeadershipError
e
    ShelleyQueryCmdTextEnvelopeReadError FileError TextEnvelopeError
e -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ FileError TextEnvelopeError -> String
forall e. Error e => e -> String
displayError FileError TextEnvelopeError
e
    ShelleyQueryCmdSlotToUtcError Text
e -> Text
"Failed to convert slot to UTC time: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
    ShelleyQueryCmdTextReadError FileError InputDecodeError
e -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ FileError InputDecodeError -> String
forall e. Error e => e -> String
displayError FileError InputDecodeError
e
    ShelleyQueryCmdColdKeyReadFileError FileError InputDecodeError
e -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ FileError InputDecodeError -> String
forall e. Error e => e -> String
displayError FileError InputDecodeError
e
    ShelleyQueryCmdOpCertCounterReadError FileError TextEnvelopeError
e -> String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ FileError TextEnvelopeError -> String
forall e. Error e => e -> String
displayError FileError TextEnvelopeError
e
    ShelleyQueryCmdProtocolStateDecodeFailure (ByteString
_, DecoderError
decErr) ->
      Text
"Failed to decode the protocol state: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
toStrict (Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ DecoderError -> Builder
forall p. Buildable p => p -> Builder
build DecoderError
decErr)
    ShelleyQueryCmdNodeUnknownStakePool String
nodeOpCert ->
      String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"The stake pool associated with: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
nodeOpCert String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" was not found. Ensure the correct KES key has been " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                  String
"specified and that the stake pool is registered. If you have submitted a stake pool registration certificate " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
                  String
"in the current epoch, you must wait until the following epoch for the registration to take place."


runQueryCmd :: QueryCmd -> ExceptT ShelleyQueryCmdError IO ()
runQueryCmd :: QueryCmd -> ExceptT ShelleyQueryCmdError IO ()
runQueryCmd QueryCmd
cmd =
  case QueryCmd
cmd of
    QueryLeadershipSchedule AnyConsensusModeParams
consensusModeParams NetworkId
network GenesisFile
shelleyGenFp VerificationKeyOrHashOrFile StakePoolKey
poolid SigningKeyFile
vrkSkeyFp EpochLeadershipSchedule
whichSchedule Maybe OutputFile
outputAs ->
      AnyConsensusModeParams
-> NetworkId
-> GenesisFile
-> VerificationKeyOrHashOrFile StakePoolKey
-> SigningKeyFile
-> EpochLeadershipSchedule
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryLeadershipSchedule AnyConsensusModeParams
consensusModeParams NetworkId
network GenesisFile
shelleyGenFp VerificationKeyOrHashOrFile StakePoolKey
poolid SigningKeyFile
vrkSkeyFp EpochLeadershipSchedule
whichSchedule Maybe OutputFile
outputAs
    QueryProtocolParameters' AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryProtocolParameters AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile
    QueryTip AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryTip AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile
    QueryStakePools' AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryStakePools AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile
    QueryStakeDistribution' AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeDistribution AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile
    QueryStakeAddressInfo AnyConsensusModeParams
consensusModeParams StakeAddress
addr NetworkId
network Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> StakeAddress
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeAddressInfo AnyConsensusModeParams
consensusModeParams StakeAddress
addr NetworkId
network Maybe OutputFile
mOutFile
    QueryDebugLedgerState' AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryLedgerState AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile
    QueryStakeSnapshot' AnyConsensusModeParams
consensusModeParams NetworkId
network Hash StakePoolKey
poolid ->
      AnyConsensusModeParams
-> NetworkId
-> Hash StakePoolKey
-> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeSnapshot AnyConsensusModeParams
consensusModeParams NetworkId
network Hash StakePoolKey
poolid
    QueryPoolParams' AnyConsensusModeParams
consensusModeParams NetworkId
network Hash StakePoolKey
poolid ->
      AnyConsensusModeParams
-> NetworkId
-> Hash StakePoolKey
-> ExceptT ShelleyQueryCmdError IO ()
runQueryPoolParams AnyConsensusModeParams
consensusModeParams NetworkId
network Hash StakePoolKey
poolid
    QueryProtocolState' AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryProtocolState AnyConsensusModeParams
consensusModeParams NetworkId
network Maybe OutputFile
mOutFile
    QueryUTxO' AnyConsensusModeParams
consensusModeParams QueryUTxOFilter
qFilter NetworkId
networkId Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> QueryUTxOFilter
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryUTxO AnyConsensusModeParams
consensusModeParams QueryUTxOFilter
qFilter NetworkId
networkId Maybe OutputFile
mOutFile
    QueryKesPeriodInfo AnyConsensusModeParams
consensusModeParams NetworkId
network String
nodeOpCert Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> NetworkId
-> String
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryKesPeriodInfo AnyConsensusModeParams
consensusModeParams NetworkId
network String
nodeOpCert Maybe OutputFile
mOutFile

runQueryProtocolParameters
  :: AnyConsensusModeParams
  -> NetworkId
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryProtocolParameters :: AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryProtocolParameters (AnyConsensusModeParams ConsensusModeParams mode
cModeParams) NetworkId
network Maybe OutputFile
mOutFile = do
  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr
                           ExceptT EnvSocketError IO SocketPath
readEnvSocketPath
  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

  Either
  AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters)
result <- IO
  (Either
     AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters))
-> ExceptT
     ShelleyQueryCmdError
     IO
     (Either
        AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either
      AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters))
 -> ExceptT
      ShelleyQueryCmdError
      IO
      (Either
         AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters)))
-> IO
     (Either
        AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters))
-> ExceptT
     ShelleyQueryCmdError
     IO
     (Either
        AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters))
forall a b. (a -> b) -> a -> b
$ LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> (NodeToClientVersion
    -> LocalStateQueryExpr
         (BlockInMode mode)
         ChainPoint
         (QueryInMode mode)
         ()
         IO
         (Either ShelleyQueryCmdError ProtocolParameters))
-> IO
     (Either
        AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters))
forall mode a.
LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> (NodeToClientVersion
    -> LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO a)
-> IO (Either AcquireFailure a)
executeLocalStateQueryExpr LocalNodeConnectInfo mode
localNodeConnInfo Maybe ChainPoint
forall a. Maybe a
Nothing ((NodeToClientVersion
  -> LocalStateQueryExpr
       (BlockInMode mode)
       ChainPoint
       (QueryInMode mode)
       ()
       IO
       (Either ShelleyQueryCmdError ProtocolParameters))
 -> IO
      (Either
         AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters)))
-> (NodeToClientVersion
    -> LocalStateQueryExpr
         (BlockInMode mode)
         ChainPoint
         (QueryInMode mode)
         ()
         IO
         (Either ShelleyQueryCmdError ProtocolParameters))
-> IO
     (Either
        AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters))
forall a b. (a -> b) -> a -> b
$ \NodeToClientVersion
_ntcVersion -> ExceptT
  ShelleyQueryCmdError
  (LocalStateQueryExpr
     (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
  ProtocolParameters
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Either ShelleyQueryCmdError ProtocolParameters)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   ShelleyQueryCmdError
   (LocalStateQueryExpr
      (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
   ProtocolParameters
 -> LocalStateQueryExpr
      (BlockInMode mode)
      ChainPoint
      (QueryInMode mode)
      ()
      IO
      (Either ShelleyQueryCmdError ProtocolParameters))
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     ProtocolParameters
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Either ShelleyQueryCmdError ProtocolParameters)
forall a b. (a -> b) -> a -> b
$ do
    anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- LocalStateQueryExpr
  (BlockInMode mode)
  ChainPoint
  (QueryInMode mode)
  ()
  IO
  AnyCardanoEra
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     AnyCardanoEra
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LocalStateQueryExpr
   (BlockInMode mode)
   ChainPoint
   (QueryInMode mode)
   ()
   IO
   AnyCardanoEra
 -> ExceptT
      ShelleyQueryCmdError
      (LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
      AnyCardanoEra)
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     AnyCardanoEra
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     AnyCardanoEra
forall a b. (a -> b) -> a -> b
$ ConsensusModeParams mode
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     AnyCardanoEra
forall mode block point r.
ConsensusModeParams mode
-> LocalStateQueryExpr
     block point (QueryInMode mode) r IO AnyCardanoEra
determineEraExpr ConsensusModeParams mode
cModeParams

    case CardanoEra era -> CardanoEraStyle era
forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era of
      CardanoEraStyle era
LegacyByronEra -> ShelleyQueryCmdError
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     ProtocolParameters
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left ShelleyQueryCmdError
ShelleyQueryCmdByronEra
      ShelleyBasedEra ShelleyBasedEra era
sbe -> do
        let cMode :: ConsensusMode mode
cMode = ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams

        EraInMode era mode
eInMode <- CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode
          Maybe (EraInMode era mode)
-> (Maybe (EraInMode era mode)
    -> ExceptT
         ShelleyQueryCmdError
         (LocalStateQueryExpr
            (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
         (EraInMode era mode))
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (EraInMode era mode)
forall a b. a -> (a -> b) -> b
& ShelleyQueryCmdError
-> Maybe (EraInMode era mode)
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (EraInMode era mode)
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe (AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE)

        Either EraMismatch ProtocolParameters
ppResult <- LocalStateQueryExpr
  (BlockInMode mode)
  ChainPoint
  (QueryInMode mode)
  ()
  IO
  (Either EraMismatch ProtocolParameters)
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (Either EraMismatch ProtocolParameters)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LocalStateQueryExpr
   (BlockInMode mode)
   ChainPoint
   (QueryInMode mode)
   ()
   IO
   (Either EraMismatch ProtocolParameters)
 -> ExceptT
      ShelleyQueryCmdError
      (LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
      (Either EraMismatch ProtocolParameters))
-> (QueryInMode mode (Either EraMismatch ProtocolParameters)
    -> LocalStateQueryExpr
         (BlockInMode mode)
         ChainPoint
         (QueryInMode mode)
         ()
         IO
         (Either EraMismatch ProtocolParameters))
-> QueryInMode mode (Either EraMismatch ProtocolParameters)
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (Either EraMismatch ProtocolParameters)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. QueryInMode mode (Either EraMismatch ProtocolParameters)
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Either EraMismatch ProtocolParameters)
forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr block point (QueryInMode mode) r IO a
queryExpr (QueryInMode mode (Either EraMismatch ProtocolParameters)
 -> ExceptT
      ShelleyQueryCmdError
      (LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
      (Either EraMismatch ProtocolParameters))
-> QueryInMode mode (Either EraMismatch ProtocolParameters)
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (Either EraMismatch ProtocolParameters)
forall a b. (a -> b) -> a -> b
$ EraInMode era mode
-> QueryInEra era ProtocolParameters
-> QueryInMode mode (Either EraMismatch ProtocolParameters)
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era ProtocolParameters
 -> QueryInMode mode (Either EraMismatch ProtocolParameters))
-> QueryInEra era ProtocolParameters
-> QueryInMode mode (Either EraMismatch ProtocolParameters)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> QueryInShelleyBasedEra era ProtocolParameters
-> QueryInEra era ProtocolParameters
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe QueryInShelleyBasedEra era ProtocolParameters
forall era. QueryInShelleyBasedEra era ProtocolParameters
QueryProtocolParameters

        Either EraMismatch ProtocolParameters
-> ExceptT
     EraMismatch
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     ProtocolParameters
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except Either EraMismatch ProtocolParameters
ppResult ExceptT
  EraMismatch
  (LocalStateQueryExpr
     (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
  ProtocolParameters
-> (ExceptT
      EraMismatch
      (LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
      ProtocolParameters
    -> ExceptT
         ShelleyQueryCmdError
         (LocalStateQueryExpr
            (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
         ProtocolParameters)
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     ProtocolParameters
forall a b. a -> (a -> b) -> b
& (EraMismatch -> ShelleyQueryCmdError)
-> ExceptT
     EraMismatch
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     ProtocolParameters
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     ProtocolParameters
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EraMismatch -> ShelleyQueryCmdError
ShelleyQueryCmdEraMismatch

  Maybe OutputFile
-> ProtocolParameters -> ExceptT ShelleyQueryCmdError IO ()
writeProtocolParameters Maybe OutputFile
mOutFile (ProtocolParameters -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT ShelleyQueryCmdError IO ProtocolParameters
-> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Either ShelleyQueryCmdError ProtocolParameters
-> ExceptT ShelleyQueryCmdError IO ProtocolParameters
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either
  ShelleyQueryCmdError
  (Either ShelleyQueryCmdError ProtocolParameters)
-> Either ShelleyQueryCmdError ProtocolParameters
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ((AcquireFailure -> ShelleyQueryCmdError)
-> Either
     AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters)
-> Either
     ShelleyQueryCmdError
     (Either ShelleyQueryCmdError ProtocolParameters)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first AcquireFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure Either
  AcquireFailure (Either ShelleyQueryCmdError ProtocolParameters)
result))
 where
  writeProtocolParameters
    :: Maybe OutputFile
    -> ProtocolParameters
    -> ExceptT ShelleyQueryCmdError IO ()
  writeProtocolParameters :: Maybe OutputFile
-> ProtocolParameters -> ExceptT ShelleyQueryCmdError IO ()
writeProtocolParameters Maybe OutputFile
mOutFile' ProtocolParameters
pparams =
    case Maybe OutputFile
mOutFile' of
      Maybe OutputFile
Nothing -> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
LBS.putStrLn (ProtocolParameters -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty ProtocolParameters
pparams)
      Just (OutputFile String
fpath) ->
        (IOException -> ShelleyQueryCmdError)
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError (FileError () -> ShelleyQueryCmdError)
-> (IOException -> FileError ())
-> IOException
-> ShelleyQueryCmdError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IOException -> FileError ()
forall e. String -> IOException -> FileError e
FileIOError String
fpath) (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$
          String -> ByteString -> IO ()
LBS.writeFile String
fpath (ProtocolParameters -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty ProtocolParameters
pparams)

-- | Calculate the percentage sync rendered as text.
percentage
  :: RelativeTime
  -- ^ 'tolerance'.  If 'b' - 'a' < 'tolerance', then 100% is reported.  This even if we are 'tolerance' seconds
  -- behind, we are still considered fully synced.
  -> RelativeTime
  -- ^ 'nowTime'.  The time of the most recently synced block.
  -> RelativeTime
  -- ^ 'tipTime'.  The time of the tip of the block chain to which we need to sync.
  -> Text
percentage :: RelativeTime -> RelativeTime -> RelativeTime -> Text
percentage RelativeTime
tolerance RelativeTime
a RelativeTime
b = String -> Text
Text.pack (String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.2f" Double
pc)
  where -- All calculations are in seconds (Integer)
        t :: Integer
t  = RelativeTime -> Integer
relativeTimeSeconds RelativeTime
tolerance
        -- Plus 1 to prevent division by zero.  The 's' prefix stands for strictly-positive.
        sa :: Integer
sa = RelativeTime -> Integer
relativeTimeSeconds RelativeTime
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
        sb :: Integer
sb = RelativeTime -> Integer
relativeTimeSeconds RelativeTime
b Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
        -- Fast forward the 'nowTime` by the tolerance, but don't let the result exceed the tip time.
        ua :: Integer
ua = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min (Integer
sa Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
t) Integer
sb
        ub :: Integer
ub = Integer
sb
        -- Final percentage to render as text.
        pc :: Double
pc = Double -> Double
forall a. a -> a
id @Double (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ua Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral  Integer
ub) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
100.0

relativeTimeSeconds :: RelativeTime -> Integer
relativeTimeSeconds :: RelativeTime -> Integer
relativeTimeSeconds (RelativeTime NominalDiffTime
dt) = Pico -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (NominalDiffTime -> Pico
nominalDiffTimeToSeconds NominalDiffTime
dt)

-- | Query the chain tip via the chain sync protocol.
--
-- This is a fallback query to support older versions of node to client protocol.
queryChainTipViaChainSync :: MonadIO m => LocalNodeConnectInfo mode -> m ChainTip
queryChainTipViaChainSync :: LocalNodeConnectInfo mode -> m ChainTip
queryChainTipViaChainSync LocalNodeConnectInfo mode
localNodeConnInfo = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Text -> IO ()) -> Text -> m ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Handle -> Text -> IO ()
T.hPutStrLn Handle
IO.stderr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
    Text
"Warning: Local header state query unavailable. Falling back to chain sync query"
  IO ChainTip -> m ChainTip
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ChainTip -> m ChainTip) -> IO ChainTip -> m ChainTip
forall a b. (a -> b) -> a -> b
$ LocalNodeConnectInfo mode -> IO ChainTip
forall mode. LocalNodeConnectInfo mode -> IO ChainTip
getLocalChainTip LocalNodeConnectInfo mode
localNodeConnInfo

runQueryTip
  :: AnyConsensusModeParams
  -> NetworkId
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryTip :: AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryTip (AnyConsensusModeParams ConsensusModeParams mode
cModeParams) NetworkId
network Maybe OutputFile
mOutFile = do
  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr ExceptT EnvSocketError IO SocketPath
readEnvSocketPath

  case ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams of
    ConsensusMode mode
CardanoMode -> do
      let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

      Either AcquireFailure (QueryTipLocalState Any)
eLocalState <- IO (Either AcquireFailure (QueryTipLocalState Any))
-> ExceptT
     ShelleyQueryCmdError
     IO
     (Either AcquireFailure (QueryTipLocalState Any))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either AcquireFailure (QueryTipLocalState Any))
 -> ExceptT
      ShelleyQueryCmdError
      IO
      (Either AcquireFailure (QueryTipLocalState Any)))
-> IO (Either AcquireFailure (QueryTipLocalState Any))
-> ExceptT
     ShelleyQueryCmdError
     IO
     (Either AcquireFailure (QueryTipLocalState Any))
forall a b. (a -> b) -> a -> b
$ LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> (NodeToClientVersion
    -> LocalStateQueryExpr
         (BlockInMode mode)
         ChainPoint
         (QueryInMode mode)
         ()
         IO
         (QueryTipLocalState Any))
-> IO (Either AcquireFailure (QueryTipLocalState Any))
forall mode a.
LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> (NodeToClientVersion
    -> LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO a)
-> IO (Either AcquireFailure a)
executeLocalStateQueryExpr LocalNodeConnectInfo mode
localNodeConnInfo Maybe ChainPoint
forall a. Maybe a
Nothing ((NodeToClientVersion
  -> LocalStateQueryExpr
       (BlockInMode mode)
       ChainPoint
       (QueryInMode mode)
       ()
       IO
       (QueryTipLocalState Any))
 -> IO (Either AcquireFailure (QueryTipLocalState Any)))
-> (NodeToClientVersion
    -> LocalStateQueryExpr
         (BlockInMode mode)
         ChainPoint
         (QueryInMode mode)
         ()
         IO
         (QueryTipLocalState Any))
-> IO (Either AcquireFailure (QueryTipLocalState Any))
forall a b. (a -> b) -> a -> b
$ \NodeToClientVersion
ntcVersion -> do
        AnyCardanoEra
era <- QueryInMode CardanoMode AnyCardanoEra
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode CardanoMode)
     ()
     IO
     AnyCardanoEra
forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr block point (QueryInMode mode) r IO a
queryExpr (ConsensusModeIsMultiEra CardanoMode
-> QueryInMode CardanoMode AnyCardanoEra
forall mode.
ConsensusModeIsMultiEra mode -> QueryInMode mode AnyCardanoEra
QueryCurrentEra ConsensusModeIsMultiEra CardanoMode
CardanoModeIsMultiEra)
        EraHistory CardanoMode
eraHistory <- QueryInMode CardanoMode (EraHistory CardanoMode)
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode CardanoMode)
     ()
     IO
     (EraHistory CardanoMode)
forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr block point (QueryInMode mode) r IO a
queryExpr (ConsensusModeIsMultiEra CardanoMode
-> QueryInMode CardanoMode (EraHistory CardanoMode)
forall mode.
ConsensusModeIsMultiEra mode -> QueryInMode mode (EraHistory mode)
QueryEraHistory ConsensusModeIsMultiEra CardanoMode
CardanoModeIsMultiEra)
        Maybe (WithOrigin BlockNo)
mChainBlockNo <- if NodeToClientVersion
ntcVersion NodeToClientVersion -> NodeToClientVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= NodeToClientVersion
NodeToClientV_10
          then WithOrigin BlockNo -> Maybe (WithOrigin BlockNo)
forall a. a -> Maybe a
Just (WithOrigin BlockNo -> Maybe (WithOrigin BlockNo))
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (WithOrigin BlockNo)
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Maybe (WithOrigin BlockNo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueryInMode mode (WithOrigin BlockNo)
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (WithOrigin BlockNo)
forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr block point (QueryInMode mode) r IO a
queryExpr QueryInMode mode (WithOrigin BlockNo)
forall mode. QueryInMode mode (WithOrigin BlockNo)
QueryChainBlockNo
          else Maybe (WithOrigin BlockNo)
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Maybe (WithOrigin BlockNo))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (WithOrigin BlockNo)
forall a. Maybe a
Nothing
        Maybe ChainPoint
mChainPoint <- if NodeToClientVersion
ntcVersion NodeToClientVersion -> NodeToClientVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= NodeToClientVersion
NodeToClientV_10
          then ChainPoint -> Maybe ChainPoint
forall a. a -> Maybe a
Just (ChainPoint -> Maybe ChainPoint)
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode CardanoMode)
     ()
     IO
     ChainPoint
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode CardanoMode)
     ()
     IO
     (Maybe ChainPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueryInMode CardanoMode ChainPoint
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode CardanoMode)
     ()
     IO
     ChainPoint
forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr block point (QueryInMode mode) r IO a
queryExpr (ConsensusMode CardanoMode -> QueryInMode CardanoMode ChainPoint
forall mode. ConsensusMode mode -> QueryInMode mode ChainPoint
QueryChainPoint ConsensusMode CardanoMode
CardanoMode)
          else Maybe ChainPoint
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Maybe ChainPoint)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ChainPoint
forall a. Maybe a
Nothing
        Maybe SystemStart
mSystemStart <- if NodeToClientVersion
ntcVersion NodeToClientVersion -> NodeToClientVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= NodeToClientVersion
NodeToClientV_9
          then SystemStart -> Maybe SystemStart
forall a. a -> Maybe a
Just (SystemStart -> Maybe SystemStart)
-> LocalStateQueryExpr
     (BlockInMode mode) ChainPoint (QueryInMode mode) () IO SystemStart
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Maybe SystemStart)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueryInMode mode SystemStart
-> LocalStateQueryExpr
     (BlockInMode mode) ChainPoint (QueryInMode mode) () IO SystemStart
forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr block point (QueryInMode mode) r IO a
queryExpr QueryInMode mode SystemStart
forall mode. QueryInMode mode SystemStart
QuerySystemStart
          else Maybe SystemStart
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Maybe SystemStart)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SystemStart
forall a. Maybe a
Nothing

        QueryTipLocalState Any
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (QueryTipLocalState Any)
forall (m :: * -> *) a. Monad m => a -> m a
return QueryTipLocalState :: forall mode.
AnyCardanoEra
-> EraHistory CardanoMode
-> Maybe SystemStart
-> Maybe ChainTip
-> QueryTipLocalState mode
O.QueryTipLocalState
          { $sel:era:QueryTipLocalState :: AnyCardanoEra
O.era = AnyCardanoEra
era
          , $sel:eraHistory:QueryTipLocalState :: EraHistory CardanoMode
O.eraHistory = EraHistory CardanoMode
eraHistory
          , $sel:mSystemStart:QueryTipLocalState :: Maybe SystemStart
O.mSystemStart = Maybe SystemStart
mSystemStart
          , $sel:mChainTip:QueryTipLocalState :: Maybe ChainTip
O.mChainTip = WithOrigin BlockNo -> ChainPoint -> ChainTip
makeChainTip (WithOrigin BlockNo -> ChainPoint -> ChainTip)
-> Maybe (WithOrigin BlockNo) -> Maybe (ChainPoint -> ChainTip)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (WithOrigin BlockNo)
mChainBlockNo Maybe (ChainPoint -> ChainTip)
-> Maybe ChainPoint -> Maybe ChainTip
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ChainPoint
mChainPoint
          }

      Maybe (QueryTipLocalState Any)
mLocalState <- Either ShelleyQueryCmdError (QueryTipLocalState Any)
-> (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT ShelleyQueryCmdError IO (Maybe (QueryTipLocalState Any))
forall e (m :: * -> *) a.
Monad m =>
Either e a -> (e -> m ()) -> m (Maybe a)
hushM ((AcquireFailure -> ShelleyQueryCmdError)
-> Either AcquireFailure (QueryTipLocalState Any)
-> Either ShelleyQueryCmdError (QueryTipLocalState Any)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first AcquireFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure Either AcquireFailure (QueryTipLocalState Any)
eLocalState) ((ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
 -> ExceptT
      ShelleyQueryCmdError IO (Maybe (QueryTipLocalState Any)))
-> (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT ShelleyQueryCmdError IO (Maybe (QueryTipLocalState Any))
forall a b. (a -> b) -> a -> b
$ \ShelleyQueryCmdError
e ->
        IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> (Text -> IO ()) -> Text -> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Handle -> Text -> IO ()
T.hPutStrLn Handle
IO.stderr (Text -> ExceptT ShelleyQueryCmdError IO ())
-> Text -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Warning: Local state unavailable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ShelleyQueryCmdError -> Text
renderShelleyQueryCmdError ShelleyQueryCmdError
e

      ChainTip
chainTip <- case Maybe (QueryTipLocalState Any)
mLocalState Maybe (QueryTipLocalState Any)
-> (QueryTipLocalState Any -> Maybe ChainTip) -> Maybe ChainTip
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= QueryTipLocalState Any -> Maybe ChainTip
forall mode. QueryTipLocalState mode -> Maybe ChainTip
O.mChainTip of
        Just ChainTip
chainTip -> ChainTip -> ExceptT ShelleyQueryCmdError IO ChainTip
forall (m :: * -> *) a. Monad m => a -> m a
return ChainTip
chainTip

        -- The chain tip is unavailable via local state query because we are connecting with an older
        -- node to client protocol so we use chain sync instead which necessitates another connection.
        -- At some point when we can stop supporting the older node to client protocols, this fallback
        -- can be removed.
        Maybe ChainTip
Nothing -> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO ChainTip
forall (m :: * -> *) mode.
MonadIO m =>
LocalNodeConnectInfo mode -> m ChainTip
queryChainTipViaChainSync LocalNodeConnectInfo mode
localNodeConnInfo

      let SlotNo
tipSlotNo :: SlotNo = case ChainTip
chainTip of
            ChainTip
ChainTipAtGenesis -> SlotNo
0
            ChainTip SlotNo
slotNo Hash BlockHeader
_ BlockNo
_ -> SlotNo
slotNo

      Maybe QueryTipLocalStateOutput
localStateOutput <- Maybe (QueryTipLocalState Any)
-> (QueryTipLocalState Any
    -> ExceptT ShelleyQueryCmdError IO QueryTipLocalStateOutput)
-> ExceptT ShelleyQueryCmdError IO (Maybe QueryTipLocalStateOutput)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (QueryTipLocalState Any)
mLocalState ((QueryTipLocalState Any
  -> ExceptT ShelleyQueryCmdError IO QueryTipLocalStateOutput)
 -> ExceptT
      ShelleyQueryCmdError IO (Maybe QueryTipLocalStateOutput))
-> (QueryTipLocalState Any
    -> ExceptT ShelleyQueryCmdError IO QueryTipLocalStateOutput)
-> ExceptT ShelleyQueryCmdError IO (Maybe QueryTipLocalStateOutput)
forall a b. (a -> b) -> a -> b
$ \QueryTipLocalState Any
localState -> do
        case SlotNo
-> EraHistory CardanoMode
-> Either
     PastHorizonException (EpochNo, SlotsInEpoch, SlotsToEpochEnd)
forall mode.
SlotNo
-> EraHistory mode
-> Either
     PastHorizonException (EpochNo, SlotsInEpoch, SlotsToEpochEnd)
slotToEpoch SlotNo
tipSlotNo (QueryTipLocalState Any -> EraHistory CardanoMode
forall mode. QueryTipLocalState mode -> EraHistory CardanoMode
O.eraHistory QueryTipLocalState Any
localState) of
          Left PastHorizonException
e -> do
            IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> (Text -> IO ()) -> Text -> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Handle -> Text -> IO ()
T.hPutStrLn Handle
IO.stderr (Text -> ExceptT ShelleyQueryCmdError IO ())
-> Text -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$
              Text
"Warning: Epoch unavailable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ShelleyQueryCmdError -> Text
renderShelleyQueryCmdError (PastHorizonException -> ShelleyQueryCmdError
ShelleyQueryCmdPastHorizon PastHorizonException
e)
            QueryTipLocalStateOutput
-> ExceptT ShelleyQueryCmdError IO QueryTipLocalStateOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (QueryTipLocalStateOutput
 -> ExceptT ShelleyQueryCmdError IO QueryTipLocalStateOutput)
-> QueryTipLocalStateOutput
-> ExceptT ShelleyQueryCmdError IO QueryTipLocalStateOutput
forall a b. (a -> b) -> a -> b
$ QueryTipLocalStateOutput :: ChainTip
-> Maybe AnyCardanoEra
-> Maybe EpochNo
-> Maybe Text
-> QueryTipLocalStateOutput
O.QueryTipLocalStateOutput
              { $sel:localStateChainTip:QueryTipLocalStateOutput :: ChainTip
O.localStateChainTip = ChainTip
chainTip
              , $sel:mEra:QueryTipLocalStateOutput :: Maybe AnyCardanoEra
O.mEra = Maybe AnyCardanoEra
forall a. Maybe a
Nothing
              , $sel:mEpoch:QueryTipLocalStateOutput :: Maybe EpochNo
O.mEpoch = Maybe EpochNo
forall a. Maybe a
Nothing
              , $sel:mSyncProgress:QueryTipLocalStateOutput :: Maybe Text
O.mSyncProgress = Maybe Text
forall a. Maybe a
Nothing
              }

          Right (EpochNo
epochNo, SlotsInEpoch
_, SlotsToEpochEnd
_) -> do
            Either ShelleyQueryCmdError Text
syncProgressResult <- ExceptT ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) Text
-> ExceptT
     ShelleyQueryCmdError IO (Either ShelleyQueryCmdError Text)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) Text
 -> ExceptT
      ShelleyQueryCmdError IO (Either ShelleyQueryCmdError Text))
-> ExceptT
     ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) Text
-> ExceptT
     ShelleyQueryCmdError IO (Either ShelleyQueryCmdError Text)
forall a b. (a -> b) -> a -> b
$ do
              UTCTime
systemStart <- (SystemStart -> UTCTime) -> Maybe SystemStart -> Maybe UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SystemStart -> UTCTime
getSystemStart (QueryTipLocalState Any -> Maybe SystemStart
forall mode. QueryTipLocalState mode -> Maybe SystemStart
O.mSystemStart QueryTipLocalState Any
localState) Maybe UTCTime
-> (Maybe UTCTime
    -> ExceptT
         ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) UTCTime)
-> ExceptT
     ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) UTCTime
forall a b. a -> (a -> b) -> b
& ShelleyQueryCmdError
-> Maybe UTCTime
-> ExceptT
     ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) UTCTime
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe ShelleyQueryCmdError
ShelleyQueryCmdSystemStartUnavailable
              RelativeTime
nowSeconds <- SystemStart -> UTCTime -> RelativeTime
toRelativeTime (UTCTime -> SystemStart
SystemStart UTCTime
systemStart) (UTCTime -> RelativeTime)
-> ExceptT
     ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) UTCTime
-> ExceptT
     ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) RelativeTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
-> ExceptT
     ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
              RelativeTime
tipTimeResult <- SlotNo
-> EraHistory CardanoMode
-> Either PastHorizonException (RelativeTime, SlotLength)
forall mode.
SlotNo
-> EraHistory mode
-> Either PastHorizonException (RelativeTime, SlotLength)
getProgress SlotNo
tipSlotNo (QueryTipLocalState Any -> EraHistory CardanoMode
forall mode. QueryTipLocalState mode -> EraHistory CardanoMode
O.eraHistory QueryTipLocalState Any
localState) Either PastHorizonException (RelativeTime, SlotLength)
-> (Either PastHorizonException (RelativeTime, SlotLength)
    -> Either ShelleyQueryCmdError RelativeTime)
-> Either ShelleyQueryCmdError RelativeTime
forall a b. a -> (a -> b) -> b
& (PastHorizonException -> ShelleyQueryCmdError)
-> ((RelativeTime, SlotLength) -> RelativeTime)
-> Either PastHorizonException (RelativeTime, SlotLength)
-> Either ShelleyQueryCmdError RelativeTime
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap PastHorizonException -> ShelleyQueryCmdError
ShelleyQueryCmdPastHorizon (RelativeTime, SlotLength) -> RelativeTime
forall a b. (a, b) -> a
fst Either ShelleyQueryCmdError RelativeTime
-> (Either ShelleyQueryCmdError RelativeTime
    -> ExceptT
         ShelleyQueryCmdError
         (ExceptT ShelleyQueryCmdError IO)
         RelativeTime)
-> ExceptT
     ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) RelativeTime
forall a b. a -> (a -> b) -> b
& Either ShelleyQueryCmdError RelativeTime
-> ExceptT
     ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) RelativeTime
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except

              let tolerance :: RelativeTime
tolerance = NominalDiffTime -> RelativeTime
RelativeTime (Pico -> NominalDiffTime
secondsToNominalDiffTime Pico
600)

              Text
-> ExceptT
     ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
 -> ExceptT
      ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) Text)
-> Text
-> ExceptT
     ShelleyQueryCmdError (ExceptT ShelleyQueryCmdError IO) Text
forall a b. (a -> b) -> a -> b
$ (RelativeTime -> RelativeTime -> Text)
-> RelativeTime -> RelativeTime -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip (RelativeTime -> RelativeTime -> RelativeTime -> Text
percentage RelativeTime
tolerance) RelativeTime
nowSeconds RelativeTime
tipTimeResult

            Maybe Text
mSyncProgress <- Either ShelleyQueryCmdError Text
-> (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT ShelleyQueryCmdError IO (Maybe Text)
forall e (m :: * -> *) a.
Monad m =>
Either e a -> (e -> m ()) -> m (Maybe a)
hushM Either ShelleyQueryCmdError Text
syncProgressResult ((ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
 -> ExceptT ShelleyQueryCmdError IO (Maybe Text))
-> (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT ShelleyQueryCmdError IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ \ShelleyQueryCmdError
e -> do
              IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> (Text -> IO ()) -> Text -> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Handle -> Text -> IO ()
T.hPutStrLn Handle
IO.stderr (Text -> ExceptT ShelleyQueryCmdError IO ())
-> Text -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Warning: Sync progress unavailable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ShelleyQueryCmdError -> Text
renderShelleyQueryCmdError ShelleyQueryCmdError
e

            QueryTipLocalStateOutput
-> ExceptT ShelleyQueryCmdError IO QueryTipLocalStateOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (QueryTipLocalStateOutput
 -> ExceptT ShelleyQueryCmdError IO QueryTipLocalStateOutput)
-> QueryTipLocalStateOutput
-> ExceptT ShelleyQueryCmdError IO QueryTipLocalStateOutput
forall a b. (a -> b) -> a -> b
$ QueryTipLocalStateOutput :: ChainTip
-> Maybe AnyCardanoEra
-> Maybe EpochNo
-> Maybe Text
-> QueryTipLocalStateOutput
O.QueryTipLocalStateOutput
              { $sel:localStateChainTip:QueryTipLocalStateOutput :: ChainTip
O.localStateChainTip = ChainTip
chainTip
              , $sel:mEra:QueryTipLocalStateOutput :: Maybe AnyCardanoEra
O.mEra = AnyCardanoEra -> Maybe AnyCardanoEra
forall a. a -> Maybe a
Just (QueryTipLocalState Any -> AnyCardanoEra
forall mode. QueryTipLocalState mode -> AnyCardanoEra
O.era QueryTipLocalState Any
localState)
              , $sel:mEpoch:QueryTipLocalStateOutput :: Maybe EpochNo
O.mEpoch = EpochNo -> Maybe EpochNo
forall a. a -> Maybe a
Just EpochNo
epochNo
              , $sel:mSyncProgress:QueryTipLocalStateOutput :: Maybe Text
O.mSyncProgress = Maybe Text
mSyncProgress
              }

      case Maybe OutputFile
mOutFile of
        Just (OutputFile String
fpath) -> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LBS.writeFile String
fpath (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe QueryTipLocalStateOutput -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Maybe QueryTipLocalStateOutput
localStateOutput
        Maybe OutputFile
Nothing                 -> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
LBS.putStrLn        (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe QueryTipLocalStateOutput -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Maybe QueryTipLocalStateOutput
localStateOutput

    ConsensusMode mode
mode -> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (AnyConsensusMode -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedMode (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
mode))

-- | Query the UTxO, filtered by a given set of addresses, from a Shelley node
-- via the local state query protocol.
--

runQueryUTxO
  :: AnyConsensusModeParams
  -> QueryUTxOFilter
  -> NetworkId
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryUTxO :: AnyConsensusModeParams
-> QueryUTxOFilter
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryUTxO (AnyConsensusModeParams ConsensusModeParams mode
cModeParams)
             QueryUTxOFilter
qfilter NetworkId
network Maybe OutputFile
mOutFile = do
  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr ExceptT EnvSocketError IO SocketPath
readEnvSocketPath
  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo
  let cMode :: ConsensusMode mode
cMode = ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams
  ShelleyBasedEra era
sbe <- CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe (CardanoEraStyle era
 -> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era))
-> CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> CardanoEraStyle era
forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era

  case CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode of
    Just EraInMode era mode
eInMode -> do
      let query :: QueryInEra era (UTxO era)
query   = ShelleyBasedEra era
-> QueryInShelleyBasedEra era (UTxO era)
-> QueryInEra era (UTxO era)
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe (QueryUTxOFilter -> QueryInShelleyBasedEra era (UTxO era)
forall era.
QueryUTxOFilter -> QueryInShelleyBasedEra era (UTxO era)
QueryUTxO QueryUTxOFilter
qfilter)
          qInMode :: QueryInMode mode (Either EraMismatch (UTxO era))
qInMode = EraInMode era mode
-> QueryInEra era (UTxO era)
-> QueryInMode mode (Either EraMismatch (UTxO era))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode QueryInEra era (UTxO era)
query
      UTxO era
result <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch (UTxO era))
-> ExceptT ShelleyQueryCmdError IO (UTxO era)
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery
                  CardanoEra era
era
                  ConsensusModeParams mode
cModeParams
                  LocalNodeConnectInfo mode
localNodeConnInfo
                  QueryInMode mode (Either EraMismatch (UTxO era))
qInMode
      ShelleyBasedEra era
-> Maybe OutputFile
-> UTxO era
-> ExceptT ShelleyQueryCmdError IO ()
forall era.
ShelleyBasedEra era
-> Maybe OutputFile
-> UTxO era
-> ExceptT ShelleyQueryCmdError IO ()
writeFilteredUTxOs ShelleyBasedEra era
sbe Maybe OutputFile
mOutFile UTxO era
result
    Maybe (EraInMode era mode)
Nothing -> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE


runQueryKesPeriodInfo
  :: AnyConsensusModeParams
  -> NetworkId
  -> FilePath
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryKesPeriodInfo :: AnyConsensusModeParams
-> NetworkId
-> String
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryKesPeriodInfo (AnyConsensusModeParams ConsensusModeParams mode
cModeParams) NetworkId
network String
nodeOpCertFile
                       Maybe OutputFile
mOutFile = do

  OperationalCertificate
opCert <- (FileError TextEnvelopeError -> ShelleyQueryCmdError)
-> ExceptT (FileError TextEnvelopeError) IO OperationalCertificate
-> ExceptT ShelleyQueryCmdError IO OperationalCertificate
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT FileError TextEnvelopeError -> ShelleyQueryCmdError
ShelleyQueryCmdOpCertCounterReadError
              (ExceptT (FileError TextEnvelopeError) IO OperationalCertificate
 -> ExceptT ShelleyQueryCmdError IO OperationalCertificate)
-> (IO
      (Either (FileError TextEnvelopeError) OperationalCertificate)
    -> ExceptT (FileError TextEnvelopeError) IO OperationalCertificate)
-> IO (Either (FileError TextEnvelopeError) OperationalCertificate)
-> ExceptT ShelleyQueryCmdError IO OperationalCertificate
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO (Either (FileError TextEnvelopeError) OperationalCertificate)
-> ExceptT (FileError TextEnvelopeError) IO OperationalCertificate
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT (IO (Either (FileError TextEnvelopeError) OperationalCertificate)
 -> ExceptT ShelleyQueryCmdError IO OperationalCertificate)
-> IO (Either (FileError TextEnvelopeError) OperationalCertificate)
-> ExceptT ShelleyQueryCmdError IO OperationalCertificate
forall a b. (a -> b) -> a -> b
$ AsType OperationalCertificate
-> String
-> IO (Either (FileError TextEnvelopeError) OperationalCertificate)
forall a.
HasTextEnvelope a =>
AsType a -> String -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope AsType OperationalCertificate
AsOperationalCertificate String
nodeOpCertFile

  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr ExceptT EnvSocketError IO SocketPath
readEnvSocketPath
  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo
  let cMode :: ConsensusMode mode
cMode = ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams
  ShelleyBasedEra era
sbe <- CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe (CardanoEraStyle era
 -> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era))
-> CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> CardanoEraStyle era
forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era
  case ConsensusMode mode
cMode of
    ConsensusMode mode
CardanoMode -> do
      EraInMode era mode
eInMode <- CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode
        Maybe (EraInMode era mode)
-> (Maybe (EraInMode era mode)
    -> ExceptT ShelleyQueryCmdError IO (EraInMode era mode))
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
forall a b. a -> (a -> b) -> b
& ShelleyQueryCmdError
-> Maybe (EraInMode era mode)
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe (AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE)

      -- We check that the KES period specified in the operational certificate is correct
      -- based on the KES period defined in the genesis parameters and the current slot number
      let genesisQinMode :: QueryInMode mode (Either EraMismatch GenesisParameters)
genesisQinMode = EraInMode era mode
-> QueryInEra era GenesisParameters
-> QueryInMode mode (Either EraMismatch GenesisParameters)
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era GenesisParameters
 -> QueryInMode CardanoMode (Either EraMismatch GenesisParameters))
-> (QueryInShelleyBasedEra era GenesisParameters
    -> QueryInEra era GenesisParameters)
-> QueryInShelleyBasedEra era GenesisParameters
-> QueryInMode CardanoMode (Either EraMismatch GenesisParameters)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShelleyBasedEra era
-> QueryInShelleyBasedEra era GenesisParameters
-> QueryInEra era GenesisParameters
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe (QueryInShelleyBasedEra era GenesisParameters
 -> QueryInMode mode (Either EraMismatch GenesisParameters))
-> QueryInShelleyBasedEra era GenesisParameters
-> QueryInMode mode (Either EraMismatch GenesisParameters)
forall a b. (a -> b) -> a -> b
$ QueryInShelleyBasedEra era GenesisParameters
forall era. QueryInShelleyBasedEra era GenesisParameters
QueryGenesisParameters
          eraHistoryQuery :: QueryInMode CardanoMode (EraHistory CardanoMode)
eraHistoryQuery = ConsensusModeIsMultiEra CardanoMode
-> QueryInMode CardanoMode (EraHistory CardanoMode)
forall mode.
ConsensusModeIsMultiEra mode -> QueryInMode mode (EraHistory mode)
QueryEraHistory ConsensusModeIsMultiEra CardanoMode
CardanoModeIsMultiEra
      GenesisParameters
gParams <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch GenesisParameters)
-> ExceptT ShelleyQueryCmdError IO GenesisParameters
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery CardanoEra era
era ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo QueryInMode mode (Either EraMismatch GenesisParameters)
genesisQinMode

      ChainTip
chainTip <- IO ChainTip -> ExceptT ShelleyQueryCmdError IO ChainTip
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ChainTip -> ExceptT ShelleyQueryCmdError IO ChainTip)
-> IO ChainTip -> ExceptT ShelleyQueryCmdError IO ChainTip
forall a b. (a -> b) -> a -> b
$ LocalNodeConnectInfo mode -> IO ChainTip
forall mode. LocalNodeConnectInfo mode -> IO ChainTip
getLocalChainTip LocalNodeConnectInfo mode
localNodeConnInfo

      let curKesPeriod :: CurrentKesPeriod
curKesPeriod = ChainTip -> GenesisParameters -> CurrentKesPeriod
currentKesPeriod ChainTip
chainTip GenesisParameters
gParams
          oCertStartKesPeriod :: OpCertStartingKesPeriod
oCertStartKesPeriod = OperationalCertificate -> OpCertStartingKesPeriod
opCertStartingKesPeriod OperationalCertificate
opCert
          oCertEndKesPeriod :: OpCertEndingKesPeriod
oCertEndKesPeriod = GenesisParameters
-> OperationalCertificate -> OpCertEndingKesPeriod
opCertEndKesPeriod GenesisParameters
gParams OperationalCertificate
opCert
          opCertIntervalInformation :: OpCertIntervalInformation
opCertIntervalInformation = GenesisParameters
-> ChainTip
-> CurrentKesPeriod
-> OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> OpCertIntervalInformation
opCertIntervalInfo GenesisParameters
gParams ChainTip
chainTip CurrentKesPeriod
curKesPeriod OpCertStartingKesPeriod
oCertStartKesPeriod OpCertEndingKesPeriod
oCertEndKesPeriod

      EraHistory CardanoMode
eraHistory <- (AcquireFailure -> ShelleyQueryCmdError)
-> ExceptT AcquireFailure IO (EraHistory CardanoMode)
-> ExceptT ShelleyQueryCmdError IO (EraHistory CardanoMode)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT AcquireFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure (ExceptT AcquireFailure IO (EraHistory CardanoMode)
 -> ExceptT ShelleyQueryCmdError IO (EraHistory CardanoMode))
-> (IO (Either AcquireFailure (EraHistory CardanoMode))
    -> ExceptT AcquireFailure IO (EraHistory CardanoMode))
-> IO (Either AcquireFailure (EraHistory CardanoMode))
-> ExceptT ShelleyQueryCmdError IO (EraHistory CardanoMode)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO (Either AcquireFailure (EraHistory CardanoMode))
-> ExceptT AcquireFailure IO (EraHistory CardanoMode)
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT (IO (Either AcquireFailure (EraHistory CardanoMode))
 -> ExceptT ShelleyQueryCmdError IO (EraHistory CardanoMode))
-> IO (Either AcquireFailure (EraHistory CardanoMode))
-> ExceptT ShelleyQueryCmdError IO (EraHistory CardanoMode)
forall a b. (a -> b) -> a -> b
$ LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> QueryInMode mode (EraHistory CardanoMode)
-> IO (Either AcquireFailure (EraHistory CardanoMode))
forall mode result.
LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> QueryInMode mode result
-> IO (Either AcquireFailure result)
queryNodeLocalState LocalNodeConnectInfo mode
localNodeConnInfo Maybe ChainPoint
forall a. Maybe a
Nothing QueryInMode mode (EraHistory CardanoMode)
QueryInMode CardanoMode (EraHistory CardanoMode)
eraHistoryQuery

      let eInfo :: EpochInfo (Either Text)
eInfo = EraHistory CardanoMode -> EpochInfo (Either Text)
toEpochInfo EraHistory CardanoMode
eraHistory


      -- We get the operational certificate counter from the protocol state and check that
      -- it is equivalent to what we have on disk.

      let ptclStateQinMode :: QueryInMode mode (Either EraMismatch (ProtocolState era))
ptclStateQinMode = EraInMode era mode
-> QueryInEra era (ProtocolState era)
-> QueryInMode mode (Either EraMismatch (ProtocolState era))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era (ProtocolState era)
 -> QueryInMode
      CardanoMode (Either EraMismatch (ProtocolState era)))
-> (QueryInShelleyBasedEra era (ProtocolState era)
    -> QueryInEra era (ProtocolState era))
-> QueryInShelleyBasedEra era (ProtocolState era)
-> QueryInMode CardanoMode (Either EraMismatch (ProtocolState era))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShelleyBasedEra era
-> QueryInShelleyBasedEra era (ProtocolState era)
-> QueryInEra era (ProtocolState era)
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe (QueryInShelleyBasedEra era (ProtocolState era)
 -> QueryInMode mode (Either EraMismatch (ProtocolState era)))
-> QueryInShelleyBasedEra era (ProtocolState era)
-> QueryInMode mode (Either EraMismatch (ProtocolState era))
forall a b. (a -> b) -> a -> b
$ QueryInShelleyBasedEra era (ProtocolState era)
forall era. QueryInShelleyBasedEra era (ProtocolState era)
QueryProtocolState
      ProtocolState era
ptclState <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch (ProtocolState era))
-> ExceptT ShelleyQueryCmdError IO (ProtocolState era)
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery CardanoEra era
era ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo QueryInMode mode (Either EraMismatch (ProtocolState era))
ptclStateQinMode

      (OpCertOnDiskCounter
onDiskC, Maybe OpCertNodeStateCounter
stateC) <- ShelleyBasedEra era
-> ((ShelleyLedgerEra era ~ ShelleyLedgerEra era,
     Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
     PraosProtocolSupportsNode (ConsensusProtocol era),
     FromCBOR (ChainDepState (ConsensusProtocol era)),
     Era (ShelleyLedgerEra era),
     HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
     Signable (VRF (Crypto (ShelleyLedgerEra era))) Seed,
     Share (TxOut (ShelleyLedgerEra era))
     ~ Interns (Credential 'Staking StandardCrypto),
     ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
     ~ Blake2b_224) =>
    ExceptT
      ShelleyQueryCmdError
      IO
      (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter))
-> ExceptT
     ShelleyQueryCmdError
     IO
     (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((ShelleyLedgerEra era ~ ledgerera,
     Crypto ledgerera ~ StandardCrypto,
     PraosProtocolSupportsNode (ConsensusProtocol era),
     FromCBOR (ChainDepState (ConsensusProtocol era)), Era ledgerera,
     HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
     Signable (VRF (Crypto ledgerera)) Seed,
     Share (TxOut (ShelleyLedgerEra era))
     ~ Interns (Credential 'Staking StandardCrypto),
     ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
     ~ Blake2b_224) =>
    a)
-> a
eligibleLeaderSlotsConstaints ShelleyBasedEra era
sbe (((ShelleyLedgerEra era ~ ShelleyLedgerEra era,
   Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
   PraosProtocolSupportsNode (ConsensusProtocol era),
   FromCBOR (ChainDepState (ConsensusProtocol era)),
   Era (ShelleyLedgerEra era),
   HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
   Signable (VRF (Crypto (ShelleyLedgerEra era))) Seed,
   Share (TxOut (ShelleyLedgerEra era))
   ~ Interns (Credential 'Staking StandardCrypto),
   ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
   ~ Blake2b_224) =>
  ExceptT
    ShelleyQueryCmdError
    IO
    (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter))
 -> ExceptT
      ShelleyQueryCmdError
      IO
      (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter))
-> ((ShelleyLedgerEra era ~ ShelleyLedgerEra era,
     Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
     PraosProtocolSupportsNode (ConsensusProtocol era),
     FromCBOR (ChainDepState (ConsensusProtocol era)),
     Era (ShelleyLedgerEra era),
     HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
     Signable (VRF (Crypto (ShelleyLedgerEra era))) Seed,
     Share (TxOut (ShelleyLedgerEra era))
     ~ Interns (Credential 'Staking StandardCrypto),
     ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
     ~ Blake2b_224) =>
    ExceptT
      ShelleyQueryCmdError
      IO
      (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter))
-> ExceptT
     ShelleyQueryCmdError
     IO
     (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
forall a b. (a -> b) -> a -> b
$ ProtocolState era
-> OperationalCertificate
-> ExceptT
     ShelleyQueryCmdError
     IO
     (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
forall era.
(PraosProtocolSupportsNode (ConsensusProtocol era),
 FromCBOR (ChainDepState (ConsensusProtocol era)),
 ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
 ~ Blake2b_224) =>
ProtocolState era
-> OperationalCertificate
-> ExceptT
     ShelleyQueryCmdError
     IO
     (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
opCertOnDiskAndStateCounters ProtocolState era
ptclState OperationalCertificate
opCert
      let counterInformation :: OpCertNodeAndOnDiskCounterInformation
counterInformation = OpCertOnDiskCounter
-> Maybe OpCertNodeStateCounter
-> OpCertNodeAndOnDiskCounterInformation
opCertNodeAndOnDiskCounters OpCertOnDiskCounter
onDiskC Maybe OpCertNodeStateCounter
stateC

      -- Always render diagnostic information
      IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> (String -> IO ())
-> String
-> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn (String -> ExceptT ShelleyQueryCmdError IO ())
-> String -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ String -> OpCertIntervalInformation -> String
renderOpCertIntervalInformation String
nodeOpCertFile OpCertIntervalInformation
opCertIntervalInformation
      IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> (String -> IO ())
-> String
-> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn (String -> ExceptT ShelleyQueryCmdError IO ())
-> String -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ String -> OpCertNodeAndOnDiskCounterInformation -> String
renderOpCertNodeAndOnDiskCounterInformation String
nodeOpCertFile OpCertNodeAndOnDiskCounterInformation
counterInformation

      let qKesInfoOutput :: QueryKesPeriodInfoOutput
qKesInfoOutput = OpCertIntervalInformation
-> OpCertNodeAndOnDiskCounterInformation
-> EpochInfo (Either Text)
-> GenesisParameters
-> QueryKesPeriodInfoOutput
createQueryKesPeriodInfoOutput OpCertIntervalInformation
opCertIntervalInformation OpCertNodeAndOnDiskCounterInformation
counterInformation EpochInfo (Either Text)
eInfo GenesisParameters
gParams
          kesPeriodInfoJSON :: ByteString
kesPeriodInfoJSON = QueryKesPeriodInfoOutput -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty QueryKesPeriodInfoOutput
qKesInfoOutput

      IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
LBS.putStrLn ByteString
kesPeriodInfoJSON
      Maybe OutputFile
-> (OutputFile -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT ShelleyQueryCmdError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe OutputFile
mOutFile (\(OutputFile String
oFp) ->
        (IOException -> ShelleyQueryCmdError)
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError (FileError () -> ShelleyQueryCmdError)
-> (IOException -> FileError ())
-> IOException
-> ShelleyQueryCmdError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IOException -> FileError ()
forall e. String -> IOException -> FileError e
FileIOError String
oFp)
          (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LBS.writeFile String
oFp ByteString
kesPeriodInfoJSON)
    ConsensusMode mode
mode -> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> (AnyConsensusMode -> ShelleyQueryCmdError)
-> AnyConsensusMode
-> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. AnyConsensusMode -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedMode (AnyConsensusMode -> ExceptT ShelleyQueryCmdError IO ())
-> AnyConsensusMode -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
mode
 where
   currentKesPeriod :: ChainTip -> GenesisParameters -> CurrentKesPeriod
   currentKesPeriod :: ChainTip -> GenesisParameters -> CurrentKesPeriod
currentKesPeriod ChainTip
ChainTipAtGenesis GenesisParameters
_ = Word64 -> CurrentKesPeriod
CurrentKesPeriod Word64
0
   currentKesPeriod (ChainTip SlotNo
currSlot Hash BlockHeader
_ BlockNo
_) GenesisParameters
gParams =
     let slotsPerKesPeriod :: Word64
slotsPerKesPeriod = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ GenesisParameters -> Int
protocolParamSlotsPerKESPeriod GenesisParameters
gParams
     in Word64 -> CurrentKesPeriod
CurrentKesPeriod (Word64 -> CurrentKesPeriod) -> Word64 -> CurrentKesPeriod
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
currSlot Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
slotsPerKesPeriod

   opCertStartingKesPeriod :: OperationalCertificate -> OpCertStartingKesPeriod
   opCertStartingKesPeriod :: OperationalCertificate -> OpCertStartingKesPeriod
opCertStartingKesPeriod = Word64 -> OpCertStartingKesPeriod
OpCertStartingKesPeriod (Word64 -> OpCertStartingKesPeriod)
-> (OperationalCertificate -> Word64)
-> OperationalCertificate
-> OpCertStartingKesPeriod
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Word64)
-> (OperationalCertificate -> Word)
-> OperationalCertificate
-> Word64
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. OperationalCertificate -> Word
getKesPeriod

   opCertEndKesPeriod :: GenesisParameters -> OperationalCertificate -> OpCertEndingKesPeriod
   opCertEndKesPeriod :: GenesisParameters
-> OperationalCertificate -> OpCertEndingKesPeriod
opCertEndKesPeriod GenesisParameters
gParams OperationalCertificate
oCert =
     let OpCertStartingKesPeriod Word64
start = OperationalCertificate -> OpCertStartingKesPeriod
opCertStartingKesPeriod OperationalCertificate
oCert
         maxKesEvo :: Word64
maxKesEvo = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ GenesisParameters -> Int
protocolParamMaxKESEvolutions GenesisParameters
gParams
     in Word64 -> OpCertEndingKesPeriod
OpCertEndingKesPeriod (Word64 -> OpCertEndingKesPeriod)
-> Word64 -> OpCertEndingKesPeriod
forall a b. (a -> b) -> a -> b
$ Word64
start Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
maxKesEvo

   -- See OCERT rule in Shelley Spec: https://hydra.iohk.io/job/Cardano/cardano-ledger-specs/shelleyLedgerSpec/latest/download-by-type/doc-pdf/ledger-spec
   opCertIntervalInfo
     :: GenesisParameters
     -> ChainTip
     -> CurrentKesPeriod
     -> OpCertStartingKesPeriod
     -> OpCertEndingKesPeriod
     -> OpCertIntervalInformation
   opCertIntervalInfo :: GenesisParameters
-> ChainTip
-> CurrentKesPeriod
-> OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> OpCertIntervalInformation
opCertIntervalInfo GenesisParameters
gParams ChainTip
currSlot' CurrentKesPeriod
c OpCertStartingKesPeriod
s e :: OpCertEndingKesPeriod
e@(OpCertEndingKesPeriod Word64
oCertEnd) =
       let cSlot :: Word64
cSlot = case ChainTip
currSlot' of
                       (ChainTip SlotNo
cSlotN Hash BlockHeader
_ BlockNo
_) -> SlotNo -> Word64
unSlotNo SlotNo
cSlotN
                       ChainTip
ChainTipAtGenesis -> Word64
0
           slotsTillExp :: SlotsTillKesKeyExpiry
slotsTillExp = SlotNo -> SlotsTillKesKeyExpiry
SlotsTillKesKeyExpiry (SlotNo -> SlotsTillKesKeyExpiry)
-> (Word64 -> SlotNo) -> Word64 -> SlotsTillKesKeyExpiry
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> SlotNo
SlotNo (Word64 -> SlotsTillKesKeyExpiry)
-> Word64 -> SlotsTillKesKeyExpiry
forall a b. (a -> b) -> a -> b
$ (Word64
oCertEnd Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GenesisParameters -> Int
protocolParamSlotsPerKESPeriod GenesisParameters
gParams)) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
cSlot
       in CurrentKesPeriod
-> OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> Maybe SlotsTillKesKeyExpiry
-> OpCertIntervalInformation
O.createOpCertIntervalInfo CurrentKesPeriod
c OpCertStartingKesPeriod
s OpCertEndingKesPeriod
e (SlotsTillKesKeyExpiry -> Maybe SlotsTillKesKeyExpiry
forall a. a -> Maybe a
Just SlotsTillKesKeyExpiry
slotsTillExp)

   opCertNodeAndOnDiskCounters
     :: OpCertOnDiskCounter
     -> Maybe OpCertNodeStateCounter
     -> OpCertNodeAndOnDiskCounterInformation
   opCertNodeAndOnDiskCounters :: OpCertOnDiskCounter
-> Maybe OpCertNodeStateCounter
-> OpCertNodeAndOnDiskCounterInformation
opCertNodeAndOnDiskCounters o :: OpCertOnDiskCounter
o@(OpCertOnDiskCounter Word64
odc) (Just n :: OpCertNodeStateCounter
n@(OpCertNodeStateCounter Word64
nsc))
     | Word64
odc Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
nsc = OpCertOnDiskCounter
-> OpCertNodeStateCounter -> OpCertNodeAndOnDiskCounterInformation
OpCertOnDiskCounterBehindNodeState OpCertOnDiskCounter
o OpCertNodeStateCounter
n
     | Bool
otherwise = OpCertOnDiskCounter
-> OpCertNodeStateCounter -> OpCertNodeAndOnDiskCounterInformation
OpCertOnDiskCounterMoreThanOrEqualToNodeState OpCertOnDiskCounter
o OpCertNodeStateCounter
n
   opCertNodeAndOnDiskCounters OpCertOnDiskCounter
o Maybe OpCertNodeStateCounter
Nothing = OpCertOnDiskCounter -> OpCertNodeAndOnDiskCounterInformation
OpCertNoBlocksMintedYet OpCertOnDiskCounter
o

   opCertExpiryUtcTime
     :: EpochInfo (Either Text)
     -> GenesisParameters
     -> OpCertEndingKesPeriod
     -> Maybe UTCTime
   opCertExpiryUtcTime :: EpochInfo (Either Text)
-> GenesisParameters -> OpCertEndingKesPeriod -> Maybe UTCTime
opCertExpiryUtcTime EpochInfo (Either Text)
eInfo GenesisParameters
gParams (OpCertEndingKesPeriod Word64
oCertExpiryKesPeriod) =
     let time :: Either Text UTCTime
time = EpochInfo (Either Text)
-> SystemStart -> SlotNo -> Either Text UTCTime
forall (m :: * -> *).
(HasCallStack, Monad m) =>
EpochInfo m -> SystemStart -> SlotNo -> m UTCTime
epochInfoSlotToUTCTime
                  EpochInfo (Either Text)
eInfo
                  (UTCTime -> SystemStart
SystemStart (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ GenesisParameters -> UTCTime
protocolParamSystemStart GenesisParameters
gParams)
                  (Word64 -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Word64
oCertExpiryKesPeriod Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (GenesisParameters -> Int
protocolParamSlotsPerKESPeriod GenesisParameters
gParams))
     in case Either Text UTCTime
time of
          Left Text
_ -> Maybe UTCTime
forall a. Maybe a
Nothing
          Right UTCTime
t -> UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
t

   renderOpCertNodeAndOnDiskCounterInformation :: FilePath -> OpCertNodeAndOnDiskCounterInformation -> String
   renderOpCertNodeAndOnDiskCounterInformation :: String -> OpCertNodeAndOnDiskCounterInformation -> String
renderOpCertNodeAndOnDiskCounterInformation String
opCertFile OpCertNodeAndOnDiskCounterInformation
opCertCounterInfo =
     case OpCertNodeAndOnDiskCounterInformation
opCertCounterInfo of
      OpCertOnDiskCounterMoreThanOrEqualToNodeState OpCertOnDiskCounter
_ OpCertNodeStateCounter
_ ->
        String
"✓ The operational certificate counter agrees with the node protocol state counter"
      OpCertOnDiskCounterBehindNodeState OpCertOnDiskCounter
onDiskC OpCertNodeStateCounter
nodeStateC ->
        String
"✗ The protocol state counter is greater than the counter in the operational certificate at: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
opCertFile String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        String
"  On disk operational certificate counter: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (OpCertOnDiskCounter -> Word64
unOpCertOnDiskCounter OpCertOnDiskCounter
onDiskC) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        String
"  Protocol state counter: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (OpCertNodeStateCounter -> Word64
unOpCertNodeStateCounter OpCertNodeStateCounter
nodeStateC)
      OpCertNoBlocksMintedYet (OpCertOnDiskCounter Word64
onDiskC) ->
        String
"✗ No blocks minted so far with the operational certificate at: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
opCertFile String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
        String
"  On disk operational certificate counter: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Word64
onDiskC


   createQueryKesPeriodInfoOutput
     :: OpCertIntervalInformation
     -> OpCertNodeAndOnDiskCounterInformation
     -> EpochInfo (Either Text)
     -> GenesisParameters
     -> O.QueryKesPeriodInfoOutput
   createQueryKesPeriodInfoOutput :: OpCertIntervalInformation
-> OpCertNodeAndOnDiskCounterInformation
-> EpochInfo (Either Text)
-> GenesisParameters
-> QueryKesPeriodInfoOutput
createQueryKesPeriodInfoOutput OpCertIntervalInformation
oCertIntervalInfo OpCertNodeAndOnDiskCounterInformation
oCertCounterInfo EpochInfo (Either Text)
eInfo GenesisParameters
gParams  =
     let (OpCertEndingKesPeriod
e, Maybe SlotsTillKesKeyExpiry
mStillExp) = case OpCertIntervalInformation
oCertIntervalInfo of
                            OpCertWithinInterval OpCertStartingKesPeriod
_ OpCertEndingKesPeriod
end CurrentKesPeriod
_ SlotsTillKesKeyExpiry
sTillExp -> (OpCertEndingKesPeriod
end, SlotsTillKesKeyExpiry -> Maybe SlotsTillKesKeyExpiry
forall a. a -> Maybe a
Just SlotsTillKesKeyExpiry
sTillExp)
                            OpCertStartingKesPeriodIsInTheFuture OpCertStartingKesPeriod
_ OpCertEndingKesPeriod
end CurrentKesPeriod
_ -> (OpCertEndingKesPeriod
end, Maybe SlotsTillKesKeyExpiry
forall a. Maybe a
Nothing)
                            OpCertExpired OpCertStartingKesPeriod
_ OpCertEndingKesPeriod
end CurrentKesPeriod
_ -> (OpCertEndingKesPeriod
end, Maybe SlotsTillKesKeyExpiry
forall a. Maybe a
Nothing)
                            OpCertSomeOtherError OpCertStartingKesPeriod
_ OpCertEndingKesPeriod
end CurrentKesPeriod
_ -> (OpCertEndingKesPeriod
end, Maybe SlotsTillKesKeyExpiry
forall a. Maybe a
Nothing)
         (OpCertOnDiskCounter
onDiskCounter, Maybe OpCertNodeStateCounter
mNodeCounter) = case OpCertNodeAndOnDiskCounterInformation
oCertCounterInfo of
                                           OpCertOnDiskCounterMoreThanOrEqualToNodeState OpCertOnDiskCounter
d OpCertNodeStateCounter
n -> (OpCertOnDiskCounter
d, OpCertNodeStateCounter -> Maybe OpCertNodeStateCounter
forall a. a -> Maybe a
Just OpCertNodeStateCounter
n)
                                           OpCertOnDiskCounterBehindNodeState OpCertOnDiskCounter
d OpCertNodeStateCounter
n -> (OpCertOnDiskCounter
d, OpCertNodeStateCounter -> Maybe OpCertNodeStateCounter
forall a. a -> Maybe a
Just OpCertNodeStateCounter
n)
                                           OpCertNoBlocksMintedYet OpCertOnDiskCounter
d -> (OpCertOnDiskCounter
d, Maybe OpCertNodeStateCounter
forall a. Maybe a
Nothing)

     in QueryKesPeriodInfoOutput :: OpCertIntervalInformation
-> Maybe UTCTime
-> Maybe OpCertNodeStateCounter
-> OpCertOnDiskCounter
-> Word64
-> Word64
-> QueryKesPeriodInfoOutput
O.QueryKesPeriodInfoOutput
        { $sel:qKesOpCertIntervalInformation:QueryKesPeriodInfoOutput :: OpCertIntervalInformation
O.qKesOpCertIntervalInformation = OpCertIntervalInformation
oCertIntervalInfo
        , $sel:qKesInfoNodeStateOperationalCertNo:QueryKesPeriodInfoOutput :: Maybe OpCertNodeStateCounter
O.qKesInfoNodeStateOperationalCertNo = Maybe OpCertNodeStateCounter
mNodeCounter
        , $sel:qKesInfoOnDiskOperationalCertNo:QueryKesPeriodInfoOutput :: OpCertOnDiskCounter
O.qKesInfoOnDiskOperationalCertNo = OpCertOnDiskCounter
onDiskCounter
        , $sel:qKesInfoMaxKesKeyEvolutions:QueryKesPeriodInfoOutput :: Word64
O.qKesInfoMaxKesKeyEvolutions = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ GenesisParameters -> Int
protocolParamMaxKESEvolutions GenesisParameters
gParams
        , $sel:qKesInfoSlotsPerKesPeriod:QueryKesPeriodInfoOutput :: Word64
O.qKesInfoSlotsPerKesPeriod = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ GenesisParameters -> Int
protocolParamSlotsPerKESPeriod GenesisParameters
gParams
        , $sel:qKesInfoKesKeyExpiry:QueryKesPeriodInfoOutput :: Maybe UTCTime
O.qKesInfoKesKeyExpiry =
            case Maybe SlotsTillKesKeyExpiry
mStillExp of
              Just SlotsTillKesKeyExpiry
_ -> EpochInfo (Either Text)
-> GenesisParameters -> OpCertEndingKesPeriod -> Maybe UTCTime
opCertExpiryUtcTime EpochInfo (Either Text)
eInfo GenesisParameters
gParams OpCertEndingKesPeriod
e
              Maybe SlotsTillKesKeyExpiry
Nothing -> Maybe UTCTime
forall a. Maybe a
Nothing
        }

   -- We get the operational certificate counter from the protocol state and check that
   -- it is equivalent to what we have on disk.
   opCertOnDiskAndStateCounters :: forall era . ()
      => Consensus.PraosProtocolSupportsNode (ConsensusProtocol era)
      => FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
      => Crypto.ADDRHASH (Consensus.PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)) ~ Blake2b.Blake2b_224
      => ProtocolState era
      -> OperationalCertificate
      -> ExceptT ShelleyQueryCmdError IO (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
   opCertOnDiskAndStateCounters :: ProtocolState era
-> OperationalCertificate
-> ExceptT
     ShelleyQueryCmdError
     IO
     (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
opCertOnDiskAndStateCounters ProtocolState era
ptclState opCert :: OperationalCertificate
opCert@(OperationalCertificate OCert StandardCrypto
_ VerificationKey StakePoolKey
stakePoolVKey) = do
    let onDiskOpCertCount :: Word64
onDiskOpCertCount = Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word64) -> Word64 -> Word64
forall a b. (a -> b) -> a -> b
$ OperationalCertificate -> Word64
getOpCertCount OperationalCertificate
opCert
    case ProtocolState era
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
forall era.
FromCBOR (ChainDepState (ConsensusProtocol era)) =>
ProtocolState era
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
decodeProtocolState ProtocolState era
ptclState of
      Left (ByteString, DecoderError)
decErr -> ShelleyQueryCmdError
-> ExceptT
     ShelleyQueryCmdError
     IO
     (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ShelleyQueryCmdError
 -> ExceptT
      ShelleyQueryCmdError
      IO
      (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter))
-> ShelleyQueryCmdError
-> ExceptT
     ShelleyQueryCmdError
     IO
     (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
forall a b. (a -> b) -> a -> b
$ (ByteString, DecoderError) -> ShelleyQueryCmdError
ShelleyQueryCmdProtocolStateDecodeFailure (ByteString, DecoderError)
decErr
      Right ChainDepState (ConsensusProtocol era)
chainDepState -> do
        -- We need the stake pool id to determine what the counter of our SPO
        -- should be.
        let opCertCounterMap :: Map
  (KeyHash
     'BlockIssuer
     (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)))
  Word64
opCertCounterMap = Proxy (ConsensusProtocol era)
-> ChainDepState (ConsensusProtocol era)
-> Map
     (KeyHash
        'BlockIssuer
        (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)))
     Word64
forall p (proxy :: * -> *).
PraosProtocolSupportsNode p =>
proxy p
-> ChainDepState p
-> Map
     (KeyHash 'BlockIssuer (PraosProtocolSupportsNodeCrypto p)) Word64
Consensus.getOpCertCounters (Proxy (ConsensusProtocol era)
forall k (t :: k). Proxy t
Proxy @(ConsensusProtocol era)) ChainDepState (ConsensusProtocol era)
chainDepState
            StakePoolKeyHash blockIssuerHash = VerificationKey StakePoolKey -> Hash StakePoolKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey StakePoolKey
stakePoolVKey

        case KeyHash
  'BlockIssuer
  (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
-> Map
     (KeyHash
        'BlockIssuer
        (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)))
     Word64
-> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (KeyHash 'StakePool StandardCrypto
-> KeyHash
     'BlockIssuer
     (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
coerce KeyHash 'StakePool StandardCrypto
blockIssuerHash) Map
  (KeyHash
     'BlockIssuer
     (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era)))
  Word64
opCertCounterMap of
          -- Operational certificate exists in the protocol state
          -- so our ondisk op cert counter must be greater than or
          -- equal to what is in the node state
          Just Word64
ptclStateCounter -> (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
-> ExceptT
     ShelleyQueryCmdError
     IO
     (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> OpCertOnDiskCounter
OpCertOnDiskCounter Word64
onDiskOpCertCount, OpCertNodeStateCounter -> Maybe OpCertNodeStateCounter
forall a. a -> Maybe a
Just (OpCertNodeStateCounter -> Maybe OpCertNodeStateCounter)
-> OpCertNodeStateCounter -> Maybe OpCertNodeStateCounter
forall a b. (a -> b) -> a -> b
$ Word64 -> OpCertNodeStateCounter
OpCertNodeStateCounter Word64
ptclStateCounter)
          Maybe Word64
Nothing -> (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
-> ExceptT
     ShelleyQueryCmdError
     IO
     (OpCertOnDiskCounter, Maybe OpCertNodeStateCounter)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> OpCertOnDiskCounter
OpCertOnDiskCounter Word64
onDiskOpCertCount, Maybe OpCertNodeStateCounter
forall a. Maybe a
Nothing)


renderOpCertIntervalInformation :: FilePath -> OpCertIntervalInformation -> String
renderOpCertIntervalInformation :: String -> OpCertIntervalInformation -> String
renderOpCertIntervalInformation String
_ (OpCertWithinInterval OpCertStartingKesPeriod
_start OpCertEndingKesPeriod
_end CurrentKesPeriod
_current SlotsTillKesKeyExpiry
_stillExp) =
  String
"✓ Operational certificate's KES period is within the correct KES period interval"
renderOpCertIntervalInformation String
opCertFile
  (OpCertStartingKesPeriodIsInTheFuture (OpCertStartingKesPeriod Word64
start)
    (OpCertEndingKesPeriod Word64
end) (CurrentKesPeriod Word64
current)) =
   String
"✗ Node operational certificate at: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
opCertFile String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" has an incorrectly specified starting KES period. " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
   String
"  Current KES period: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Word64
current String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
   String
"  Operational certificate's starting KES period: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Word64
start String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
   String
"  Operational certificate's expiry KES period: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Word64
end
renderOpCertIntervalInformation String
opCertFile (OpCertExpired OpCertStartingKesPeriod
_ (OpCertEndingKesPeriod Word64
end) (CurrentKesPeriod Word64
current)) =
  String
"✗ Node operational certificate at: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
opCertFile String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" has expired. " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
  String
"  Current KES period: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Word64
current String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
  String
"  Operational certificate's expiry KES period: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Word64
end
renderOpCertIntervalInformation String
opCertFile
  (OpCertSomeOtherError (OpCertStartingKesPeriod Word64
start) (OpCertEndingKesPeriod Word64
end) (CurrentKesPeriod Word64
current)) =
    String
"✗ An unknown error occurred with operational certificate at: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
opCertFile String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    String
"  Current KES period: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Word64
current String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    String
"  Operational certificate's starting KES period: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Word64
start String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
    String
"  Operational certificate's expiry KES period: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Word64
end

-- | Query the current and future parameters for a stake pool, including the retirement date.
-- Any of these may be empty (in which case a null will be displayed).
--
runQueryPoolParams
  :: AnyConsensusModeParams
  -> NetworkId
  -> Hash StakePoolKey
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryPoolParams :: AnyConsensusModeParams
-> NetworkId
-> Hash StakePoolKey
-> ExceptT ShelleyQueryCmdError IO ()
runQueryPoolParams (AnyConsensusModeParams ConsensusModeParams mode
cModeParams) NetworkId
network Hash StakePoolKey
poolid = do
  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr ExceptT EnvSocketError IO SocketPath
readEnvSocketPath
  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo
  let cMode :: ConsensusMode mode
cMode = ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams
  ShelleyBasedEra era
sbe <- CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe (CardanoEraStyle era
 -> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era))
-> CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> CardanoEraStyle era
forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era

  EraInMode era mode
eInMode <- CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode
    Maybe (EraInMode era mode)
-> (Maybe (EraInMode era mode)
    -> ExceptT ShelleyQueryCmdError IO (EraInMode era mode))
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
forall a b. a -> (a -> b) -> b
& ShelleyQueryCmdError
-> Maybe (EraInMode era mode)
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe (AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE)

  let qInMode :: QueryInMode
  mode (Either EraMismatch (SerialisedDebugLedgerState era))
qInMode = EraInMode era mode
-> QueryInEra era (SerialisedDebugLedgerState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era (SerialisedDebugLedgerState era)
 -> QueryInMode
      mode (Either EraMismatch (SerialisedDebugLedgerState era)))
-> (QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
    -> QueryInEra era (SerialisedDebugLedgerState era))
-> QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShelleyBasedEra era
-> QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
-> QueryInEra era (SerialisedDebugLedgerState era)
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe (QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
 -> QueryInMode
      mode (Either EraMismatch (SerialisedDebugLedgerState era)))
-> QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
forall a b. (a -> b) -> a -> b
$ QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
forall era.
QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
QueryDebugLedgerState
  SerialisedDebugLedgerState era
result <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
-> ExceptT ShelleyQueryCmdError IO (SerialisedDebugLedgerState era)
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery CardanoEra era
era ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo QueryInMode
  mode (Either EraMismatch (SerialisedDebugLedgerState era))
qInMode
  ShelleyBasedEra era
-> ((UsesValue (ShelleyLedgerEra era),
     ToJSON (DebugLedgerState era), FromCBOR (DebugLedgerState era),
     Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
     ToJSON (PParams (ShelleyLedgerEra era))) =>
    SerialisedDebugLedgerState era
    -> ExceptT ShelleyQueryCmdError IO ())
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((UsesValue ledgerera, ToJSON (DebugLedgerState era),
     FromCBOR (DebugLedgerState era), Crypto ledgerera ~ StandardCrypto,
     ToJSON (PParams ledgerera)) =>
    a)
-> a
obtainLedgerEraClassConstraints ShelleyBasedEra era
sbe (Hash StakePoolKey
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera, FromCBOR (DebugLedgerState era),
 Crypto (Crypto ledgerera), Crypto ledgerera ~ StandardCrypto) =>
Hash StakePoolKey
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
writePoolParams Hash StakePoolKey
poolid) SerialisedDebugLedgerState era
result


-- | Obtain stake snapshot information for a pool, plus information about the total active stake.
-- This information can be used for leader slot calculation, for example, and has been requested by SPOs.
-- Obtaining the information directly is significantly more time and memory efficient than using a full ledger state dump.
runQueryStakeSnapshot
  :: AnyConsensusModeParams
  -> NetworkId
  -> Hash StakePoolKey
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeSnapshot :: AnyConsensusModeParams
-> NetworkId
-> Hash StakePoolKey
-> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeSnapshot (AnyConsensusModeParams ConsensusModeParams mode
cModeParams) NetworkId
network Hash StakePoolKey
poolid = do
  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr ExceptT EnvSocketError IO SocketPath
readEnvSocketPath
  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo
  let cMode :: ConsensusMode mode
cMode = ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams
  ShelleyBasedEra era
sbe <- CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe (CardanoEraStyle era
 -> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era))
-> CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> CardanoEraStyle era
forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era

  EraInMode era mode
eInMode <- CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode
    Maybe (EraInMode era mode)
-> (Maybe (EraInMode era mode)
    -> ExceptT ShelleyQueryCmdError IO (EraInMode era mode))
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
forall a b. a -> (a -> b) -> b
& ShelleyQueryCmdError
-> Maybe (EraInMode era mode)
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe (AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE)

  let qInMode :: QueryInMode
  mode (Either EraMismatch (SerialisedDebugLedgerState era))
qInMode = EraInMode era mode
-> QueryInEra era (SerialisedDebugLedgerState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era (SerialisedDebugLedgerState era)
 -> QueryInMode
      mode (Either EraMismatch (SerialisedDebugLedgerState era)))
-> (QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
    -> QueryInEra era (SerialisedDebugLedgerState era))
-> QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShelleyBasedEra era
-> QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
-> QueryInEra era (SerialisedDebugLedgerState era)
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe (QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
 -> QueryInMode
      mode (Either EraMismatch (SerialisedDebugLedgerState era)))
-> QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
forall a b. (a -> b) -> a -> b
$ QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
forall era.
QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
QueryDebugLedgerState
  SerialisedDebugLedgerState era
result <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
-> ExceptT ShelleyQueryCmdError IO (SerialisedDebugLedgerState era)
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery CardanoEra era
era ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo QueryInMode
  mode (Either EraMismatch (SerialisedDebugLedgerState era))
qInMode
  ShelleyBasedEra era
-> ((UsesValue (ShelleyLedgerEra era),
     ToJSON (DebugLedgerState era), FromCBOR (DebugLedgerState era),
     Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
     ToJSON (PParams (ShelleyLedgerEra era))) =>
    SerialisedDebugLedgerState era
    -> ExceptT ShelleyQueryCmdError IO ())
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((UsesValue ledgerera, ToJSON (DebugLedgerState era),
     FromCBOR (DebugLedgerState era), Crypto ledgerera ~ StandardCrypto,
     ToJSON (PParams ledgerera)) =>
    a)
-> a
obtainLedgerEraClassConstraints ShelleyBasedEra era
sbe (Hash StakePoolKey
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto,
 FromCBOR (DebugLedgerState era)) =>
Hash StakePoolKey
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
writeStakeSnapshot Hash StakePoolKey
poolid) SerialisedDebugLedgerState era
result


runQueryLedgerState
  :: AnyConsensusModeParams
  -> NetworkId
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryLedgerState :: AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryLedgerState (AnyConsensusModeParams ConsensusModeParams mode
cModeParams)
                    NetworkId
network Maybe OutputFile
mOutFile = do
  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr ExceptT EnvSocketError IO SocketPath
readEnvSocketPath
  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo
  let cMode :: ConsensusMode mode
cMode = ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams
  ShelleyBasedEra era
sbe <- CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe (CardanoEraStyle era
 -> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era))
-> CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> CardanoEraStyle era
forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era

  case CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode of
    Just EraInMode era mode
eInMode -> do
      let qInMode :: QueryInMode
  mode (Either EraMismatch (SerialisedDebugLedgerState era))
qInMode = EraInMode era mode
-> QueryInEra era (SerialisedDebugLedgerState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode
                      (QueryInEra era (SerialisedDebugLedgerState era)
 -> QueryInMode
      mode (Either EraMismatch (SerialisedDebugLedgerState era)))
-> (QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
    -> QueryInEra era (SerialisedDebugLedgerState era))
-> QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShelleyBasedEra era
-> QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
-> QueryInEra era (SerialisedDebugLedgerState era)
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe
                      (QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
 -> QueryInMode
      mode (Either EraMismatch (SerialisedDebugLedgerState era)))
-> QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
forall a b. (a -> b) -> a -> b
$ QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
forall era.
QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
QueryDebugLedgerState
      SerialisedDebugLedgerState era
result <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode
     mode (Either EraMismatch (SerialisedDebugLedgerState era))
-> ExceptT ShelleyQueryCmdError IO (SerialisedDebugLedgerState era)
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery
                  CardanoEra era
era
                  ConsensusModeParams mode
cModeParams
                  LocalNodeConnectInfo mode
localNodeConnInfo
                  QueryInMode
  mode (Either EraMismatch (SerialisedDebugLedgerState era))
qInMode
      ShelleyBasedEra era
-> ((UsesValue (ShelleyLedgerEra era),
     ToJSON (DebugLedgerState era), FromCBOR (DebugLedgerState era),
     Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
     ToJSON (PParams (ShelleyLedgerEra era))) =>
    SerialisedDebugLedgerState era
    -> ExceptT ShelleyQueryCmdError IO ())
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((UsesValue ledgerera, ToJSON (DebugLedgerState era),
     FromCBOR (DebugLedgerState era), Crypto ledgerera ~ StandardCrypto,
     ToJSON (PParams ledgerera)) =>
    a)
-> a
obtainLedgerEraClassConstraints ShelleyBasedEra era
sbe (Maybe OutputFile
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera, ToJSON (DebugLedgerState era),
 FromCBOR (DebugLedgerState era)) =>
Maybe OutputFile
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
writeLedgerState Maybe OutputFile
mOutFile) SerialisedDebugLedgerState era
result
    Maybe (EraInMode era mode)
Nothing -> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE


runQueryProtocolState
  :: AnyConsensusModeParams
  -> NetworkId
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryProtocolState :: AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryProtocolState (AnyConsensusModeParams ConsensusModeParams mode
cModeParams)
                      NetworkId
network Maybe OutputFile
mOutFile = do
  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr ExceptT EnvSocketError IO SocketPath
readEnvSocketPath
  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo
  let cMode :: ConsensusMode mode
cMode = ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams
  ShelleyBasedEra era
sbe <- CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe (CardanoEraStyle era
 -> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era))
-> CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> CardanoEraStyle era
forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era

  case CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode of
    Just EraInMode era mode
eInMode -> do
      let qInMode :: QueryInMode mode (Either EraMismatch (ProtocolState era))
qInMode = EraInMode era mode
-> QueryInEra era (ProtocolState era)
-> QueryInMode mode (Either EraMismatch (ProtocolState era))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode
                      (QueryInEra era (ProtocolState era)
 -> QueryInMode mode (Either EraMismatch (ProtocolState era)))
-> (QueryInShelleyBasedEra era (ProtocolState era)
    -> QueryInEra era (ProtocolState era))
-> QueryInShelleyBasedEra era (ProtocolState era)
-> QueryInMode mode (Either EraMismatch (ProtocolState era))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShelleyBasedEra era
-> QueryInShelleyBasedEra era (ProtocolState era)
-> QueryInEra era (ProtocolState era)
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe
                      (QueryInShelleyBasedEra era (ProtocolState era)
 -> QueryInMode mode (Either EraMismatch (ProtocolState era)))
-> QueryInShelleyBasedEra era (ProtocolState era)
-> QueryInMode mode (Either EraMismatch (ProtocolState era))
forall a b. (a -> b) -> a -> b
$ QueryInShelleyBasedEra era (ProtocolState era)
forall era. QueryInShelleyBasedEra era (ProtocolState era)
QueryProtocolState
      ProtocolState era
result <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch (ProtocolState era))
-> ExceptT ShelleyQueryCmdError IO (ProtocolState era)
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery
                  CardanoEra era
era
                  ConsensusModeParams mode
cModeParams
                  LocalNodeConnectInfo mode
localNodeConnInfo
                  QueryInMode mode (Either EraMismatch (ProtocolState era))
qInMode

      case ConsensusMode mode
cMode of
        ConsensusMode mode
CardanoMode -> ShelleyBasedEra era
-> ((FromCBOR (ChainDepState (ConsensusProtocol era)),
     ToJSON (ChainDepState (ConsensusProtocol era))) =>
    ExceptT ShelleyQueryCmdError IO ())
-> ExceptT ShelleyQueryCmdError IO ()
forall era a.
ShelleyBasedEra era
-> ((FromCBOR (ChainDepState (ConsensusProtocol era)),
     ToJSON (ChainDepState (ConsensusProtocol era))) =>
    a)
-> a
eligibleWriteProtocolStateConstaints ShelleyBasedEra era
sbe (((FromCBOR (ChainDepState (ConsensusProtocol era)),
   ToJSON (ChainDepState (ConsensusProtocol era))) =>
  ExceptT ShelleyQueryCmdError IO ())
 -> ExceptT ShelleyQueryCmdError IO ())
-> ((FromCBOR (ChainDepState (ConsensusProtocol era)),
     ToJSON (ChainDepState (ConsensusProtocol era))) =>
    ExceptT ShelleyQueryCmdError IO ())
-> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ Maybe OutputFile
-> ProtocolState era -> ExceptT ShelleyQueryCmdError IO ()
forall era.
(FromCBOR (ChainDepState (ConsensusProtocol era)),
 ToJSON (ChainDepState (ConsensusProtocol era))) =>
Maybe OutputFile
-> ProtocolState era -> ExceptT ShelleyQueryCmdError IO ()
writeProtocolState Maybe OutputFile
mOutFile ProtocolState era
result
        ConsensusMode mode
mode -> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> (AnyConsensusMode -> ShelleyQueryCmdError)
-> AnyConsensusMode
-> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. AnyConsensusMode -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedMode (AnyConsensusMode -> ExceptT ShelleyQueryCmdError IO ())
-> AnyConsensusMode -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
mode

    Maybe (EraInMode era mode)
Nothing -> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE

-- | Query the current delegations and reward accounts, filtered by a given
-- set of addresses, from a Shelley node via the local state query protocol.

runQueryStakeAddressInfo
  :: AnyConsensusModeParams
  -> StakeAddress
  -> NetworkId
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeAddressInfo :: AnyConsensusModeParams
-> StakeAddress
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeAddressInfo (AnyConsensusModeParams ConsensusModeParams mode
cModeParams)
                         (StakeAddress Network
_ Credential 'Staking StandardCrypto
addr) NetworkId
network Maybe OutputFile
mOutFile = do
  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr ExceptT EnvSocketError IO SocketPath
readEnvSocketPath
  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo
  let cMode :: ConsensusMode mode
cMode = ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams
  ShelleyBasedEra era
sbe <- CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe (CardanoEraStyle era
 -> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era))
-> CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> CardanoEraStyle era
forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era

  case CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode of
    Just EraInMode era mode
eInMode -> do
      let stakeAddr :: Set StakeCredential
stakeAddr = StakeCredential -> Set StakeCredential
forall a. a -> Set a
Set.singleton (StakeCredential -> Set StakeCredential)
-> StakeCredential -> Set StakeCredential
forall a b. (a -> b) -> a -> b
$ Credential 'Staking StandardCrypto -> StakeCredential
fromShelleyStakeCredential Credential 'Staking StandardCrypto
addr
          query :: QueryInMode
  mode
  (Either
     EraMismatch
     (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey)))
query = EraInMode era mode
-> QueryInEra
     era
     (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
-> QueryInMode
     mode
     (Either
        EraMismatch
        (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey)))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode
                    (QueryInEra
   era
   (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
 -> QueryInMode
      mode
      (Either
         EraMismatch
         (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))))
-> (QueryInShelleyBasedEra
      era
      (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
    -> QueryInEra
         era
         (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey)))
-> QueryInShelleyBasedEra
     era
     (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
-> QueryInMode
     mode
     (Either
        EraMismatch
        (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey)))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShelleyBasedEra era
-> QueryInShelleyBasedEra
     era
     (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
-> QueryInEra
     era
     (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe
                    (QueryInShelleyBasedEra
   era
   (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
 -> QueryInMode
      mode
      (Either
         EraMismatch
         (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))))
-> QueryInShelleyBasedEra
     era
     (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
-> QueryInMode
     mode
     (Either
        EraMismatch
        (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey)))
forall a b. (a -> b) -> a -> b
$ Set StakeCredential
-> NetworkId
-> QueryInShelleyBasedEra
     era
     (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
forall era.
Set StakeCredential
-> NetworkId
-> QueryInShelleyBasedEra
     era
     (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
QueryStakeAddresses Set StakeCredential
stakeAddr NetworkId
network

      (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
result <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode
     mode
     (Either
        EraMismatch
        (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey)))
-> ExceptT
     ShelleyQueryCmdError
     IO
     (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery
                  CardanoEra era
era
                  ConsensusModeParams mode
cModeParams
                  LocalNodeConnectInfo mode
localNodeConnInfo
                  QueryInMode
  mode
  (Either
     EraMismatch
     (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey)))
query
      Maybe OutputFile
-> DelegationsAndRewards -> ExceptT ShelleyQueryCmdError IO ()
writeStakeAddressInfo Maybe OutputFile
mOutFile (DelegationsAndRewards -> ExceptT ShelleyQueryCmdError IO ())
-> DelegationsAndRewards -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
-> DelegationsAndRewards
DelegationsAndRewards (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
result
    Maybe (EraInMode era mode)
Nothing -> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE

-- -------------------------------------------------------------------------------------------------

-- | An error that can occur while querying a node's local state.
data ShelleyQueryCmdLocalStateQueryError
  = AcquireFailureError !LocalStateQuery.AcquireFailure
  | EraMismatchError !EraMismatch
  -- ^ A query from a certain era was applied to a ledger from a different
  -- era.
  | ByronProtocolNotSupportedError
  -- ^ The query does not support the Byron protocol.
  | ShelleyProtocolEraMismatch
  -- ^ The Shelley protocol only supports the Shelley era.
  deriving (ShelleyQueryCmdLocalStateQueryError
-> ShelleyQueryCmdLocalStateQueryError -> Bool
(ShelleyQueryCmdLocalStateQueryError
 -> ShelleyQueryCmdLocalStateQueryError -> Bool)
-> (ShelleyQueryCmdLocalStateQueryError
    -> ShelleyQueryCmdLocalStateQueryError -> Bool)
-> Eq ShelleyQueryCmdLocalStateQueryError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ShelleyQueryCmdLocalStateQueryError
-> ShelleyQueryCmdLocalStateQueryError -> Bool
$c/= :: ShelleyQueryCmdLocalStateQueryError
-> ShelleyQueryCmdLocalStateQueryError -> Bool
== :: ShelleyQueryCmdLocalStateQueryError
-> ShelleyQueryCmdLocalStateQueryError -> Bool
$c== :: ShelleyQueryCmdLocalStateQueryError
-> ShelleyQueryCmdLocalStateQueryError -> Bool
Eq, Int -> ShelleyQueryCmdLocalStateQueryError -> ShowS
[ShelleyQueryCmdLocalStateQueryError] -> ShowS
ShelleyQueryCmdLocalStateQueryError -> String
(Int -> ShelleyQueryCmdLocalStateQueryError -> ShowS)
-> (ShelleyQueryCmdLocalStateQueryError -> String)
-> ([ShelleyQueryCmdLocalStateQueryError] -> ShowS)
-> Show ShelleyQueryCmdLocalStateQueryError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShelleyQueryCmdLocalStateQueryError] -> ShowS
$cshowList :: [ShelleyQueryCmdLocalStateQueryError] -> ShowS
show :: ShelleyQueryCmdLocalStateQueryError -> String
$cshow :: ShelleyQueryCmdLocalStateQueryError -> String
showsPrec :: Int -> ShelleyQueryCmdLocalStateQueryError -> ShowS
$cshowsPrec :: Int -> ShelleyQueryCmdLocalStateQueryError -> ShowS
Show)

renderLocalStateQueryError :: ShelleyQueryCmdLocalStateQueryError -> Text
renderLocalStateQueryError :: ShelleyQueryCmdLocalStateQueryError -> Text
renderLocalStateQueryError ShelleyQueryCmdLocalStateQueryError
lsqErr =
  case ShelleyQueryCmdLocalStateQueryError
lsqErr of
    AcquireFailureError AcquireFailure
err -> Text
"Local state query acquire failure: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AcquireFailure -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show AcquireFailure
err
    EraMismatchError EraMismatch
err ->
      Text
"A query from a certain era was applied to a ledger from a different era: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EraMismatch -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show EraMismatch
err
    ShelleyQueryCmdLocalStateQueryError
ByronProtocolNotSupportedError ->
      Text
"The attempted local state query does not support the Byron protocol."
    ShelleyQueryCmdLocalStateQueryError
ShelleyProtocolEraMismatch ->
        Text
"The Shelley protocol mode can only be used with the Shelley era, "
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"i.e. with --shelley-mode use --shelley-era flag"

writeStakeAddressInfo
  :: Maybe OutputFile
  -> DelegationsAndRewards
  -> ExceptT ShelleyQueryCmdError IO ()
writeStakeAddressInfo :: Maybe OutputFile
-> DelegationsAndRewards -> ExceptT ShelleyQueryCmdError IO ()
writeStakeAddressInfo Maybe OutputFile
mOutFile DelegationsAndRewards
delegsAndRewards =
  case Maybe OutputFile
mOutFile of
    Maybe OutputFile
Nothing -> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
LBS.putStrLn (DelegationsAndRewards -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty DelegationsAndRewards
delegsAndRewards)
    Just (OutputFile String
fpath) ->
      (IOException -> ShelleyQueryCmdError)
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError (FileError () -> ShelleyQueryCmdError)
-> (IOException -> FileError ())
-> IOException
-> ShelleyQueryCmdError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IOException -> FileError ()
forall e. String -> IOException -> FileError e
FileIOError String
fpath)
        (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LBS.writeFile String
fpath (DelegationsAndRewards -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty DelegationsAndRewards
delegsAndRewards)

writeLedgerState :: forall era ledgerera.
                    ShelleyLedgerEra era ~ ledgerera
                 => ToJSON (DebugLedgerState era)
                 => FromCBOR (DebugLedgerState era)
                 => Maybe OutputFile
                 -> SerialisedDebugLedgerState era
                 -> ExceptT ShelleyQueryCmdError IO ()
writeLedgerState :: Maybe OutputFile
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
writeLedgerState Maybe OutputFile
mOutFile qState :: SerialisedDebugLedgerState era
qState@(SerialisedDebugLedgerState Serialised (NewEpochState (ShelleyLedgerEra era))
serLedgerState) =
  case Maybe OutputFile
mOutFile of
    Maybe OutputFile
Nothing -> case SerialisedDebugLedgerState era
-> Either ByteString (DebugLedgerState era)
forall era.
FromCBOR (DebugLedgerState era) =>
SerialisedDebugLedgerState era
-> Either ByteString (DebugLedgerState era)
decodeDebugLedgerState SerialisedDebugLedgerState era
qState of
                 Left ByteString
bs -> (HelpersError -> ShelleyQueryCmdError)
-> ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT HelpersError -> ShelleyQueryCmdError
ShelleyQueryCmdHelpersError (ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ExceptT HelpersError IO ()
pPrintCBOR ByteString
bs
                 Right DebugLedgerState era
ledgerState -> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> (ByteString -> IO ())
-> ByteString
-> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> IO ()
LBS.putStrLn (ByteString -> ExceptT ShelleyQueryCmdError IO ())
-> ByteString -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ DebugLedgerState era -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty DebugLedgerState era
ledgerState
    Just (OutputFile String
fpath) ->
      (IOException -> ShelleyQueryCmdError)
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError (FileError () -> ShelleyQueryCmdError)
-> (IOException -> FileError ())
-> IOException
-> ShelleyQueryCmdError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IOException -> FileError ()
forall e. String -> IOException -> FileError e
FileIOError String
fpath)
        (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LBS.writeFile String
fpath (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Serialised (NewEpochState ledgerera) -> ByteString
forall a. Serialised a -> ByteString
unSerialised Serialised (NewEpochState ledgerera)
Serialised (NewEpochState (ShelleyLedgerEra era))
serLedgerState

writeStakeSnapshot :: forall era ledgerera. ()
  => ShelleyLedgerEra era ~ ledgerera
  => Era.Crypto ledgerera ~ StandardCrypto
  => FromCBOR (DebugLedgerState era)
  => PoolId
  -> SerialisedDebugLedgerState era
  -> ExceptT ShelleyQueryCmdError IO ()
writeStakeSnapshot :: Hash StakePoolKey
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
writeStakeSnapshot (StakePoolKeyHash hk) SerialisedDebugLedgerState era
qState =
  case SerialisedDebugLedgerState era
-> Either ByteString (DebugLedgerState era)
forall era.
FromCBOR (DebugLedgerState era) =>
SerialisedDebugLedgerState era
-> Either ByteString (DebugLedgerState era)
decodeDebugLedgerState SerialisedDebugLedgerState era
qState of
    -- In the event of decode failure print the CBOR instead
    Left ByteString
bs -> (HelpersError -> ShelleyQueryCmdError)
-> ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT HelpersError -> ShelleyQueryCmdError
ShelleyQueryCmdHelpersError (ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ExceptT HelpersError IO ()
pPrintCBOR ByteString
bs

    Right DebugLedgerState era
ledgerState -> do
      -- Ledger State
      let (DebugLedgerState NewEpochState ledgerera
snapshot) = DebugLedgerState era
ledgerState

      -- The three stake snapshots, obtained from the ledger state
      let (SnapShots SnapShot StandardCrypto
markS SnapShot StandardCrypto
setS SnapShot StandardCrypto
goS Coin
_) = EpochState ledgerera -> SnapShots (Crypto ledgerera)
forall era. EpochState era -> SnapShots (Crypto era)
esSnapshots (EpochState ledgerera -> SnapShots (Crypto ledgerera))
-> EpochState ledgerera -> SnapShots (Crypto ledgerera)
forall a b. (a -> b) -> a -> b
$ NewEpochState ledgerera -> EpochState ledgerera
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState ledgerera
snapshot

      -- Calculate the three pool and active stake values for the given pool
      IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> (ByteString -> IO ())
-> ByteString
-> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> IO ()
LBS.putStrLn (ByteString -> ExceptT ShelleyQueryCmdError IO ())
-> ByteString -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ Stakes -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (Stakes -> ByteString) -> Stakes -> ByteString
forall a b. (a -> b) -> a -> b
$ Stakes :: Integer
-> Integer -> Integer -> Integer -> Integer -> Integer -> Stakes
Stakes
        { markPool :: Integer
markPool = KeyHash 'StakePool StandardCrypto
-> SnapShot StandardCrypto -> Integer
forall crypto.
KeyHash 'StakePool crypto -> SnapShot crypto -> Integer
getPoolStake KeyHash 'StakePool StandardCrypto
hk SnapShot StandardCrypto
markS
        , setPool :: Integer
setPool = KeyHash 'StakePool StandardCrypto
-> SnapShot StandardCrypto -> Integer
forall crypto.
KeyHash 'StakePool crypto -> SnapShot crypto -> Integer
getPoolStake KeyHash 'StakePool StandardCrypto
hk SnapShot StandardCrypto
setS
        , goPool :: Integer
goPool = KeyHash 'StakePool StandardCrypto
-> SnapShot StandardCrypto -> Integer
forall crypto.
KeyHash 'StakePool crypto -> SnapShot crypto -> Integer
getPoolStake KeyHash 'StakePool StandardCrypto
hk SnapShot StandardCrypto
goS
        , markTotal :: Integer
markTotal = SnapShot StandardCrypto -> Integer
forall crypto. SnapShot crypto -> Integer
getAllStake SnapShot StandardCrypto
markS
        , setTotal :: Integer
setTotal = SnapShot StandardCrypto -> Integer
forall crypto. SnapShot crypto -> Integer
getAllStake SnapShot StandardCrypto
setS
        , goTotal :: Integer
goTotal = SnapShot StandardCrypto -> Integer
forall crypto. SnapShot crypto -> Integer
getAllStake SnapShot StandardCrypto
goS
        }

-- | Sum all the stake that is held by the pool
getPoolStake :: KeyHash Cardano.Ledger.Keys.StakePool crypto -> SnapShot crypto -> Integer
getPoolStake :: KeyHash 'StakePool crypto -> SnapShot crypto -> Integer
getPoolStake KeyHash 'StakePool crypto
hash SnapShot crypto
ss = Integer
pStake
  where
    Coin Integer
pStake = Map (Credential 'Staking crypto) Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ((CompactForm Coin -> Coin)
-> Map (Credential 'Staking crypto) (CompactForm Coin)
-> Map (Credential 'Staking crypto) Coin
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (Map (Credential 'Staking crypto) (CompactForm Coin)
 -> Map (Credential 'Staking crypto) Coin)
-> Map (Credential 'Staking crypto) (CompactForm Coin)
-> Map (Credential 'Staking crypto) Coin
forall a b. (a -> b) -> a -> b
$ VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
-> Map (Credential 'Staking crypto) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
s)
    Stake VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
s = KeyHash 'StakePool crypto
-> VMap
     VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
-> Stake crypto
-> Stake crypto
forall crypto.
KeyHash 'StakePool crypto
-> VMap
     VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
-> Stake crypto
-> Stake crypto
poolStake KeyHash 'StakePool crypto
hash (SnapShot crypto
-> VMap
     VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
forall crypto.
SnapShot crypto
-> VMap
     VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
_delegations SnapShot crypto
ss) (SnapShot crypto -> Stake crypto
forall crypto. SnapShot crypto -> Stake crypto
_stake SnapShot crypto
ss)

-- | Sum the active stake from a snapshot
getAllStake :: SnapShot crypto -> Integer
getAllStake :: SnapShot crypto -> Integer
getAllStake (SnapShot Stake crypto
stake VMap VB VB (Credential 'Staking crypto) (KeyHash 'StakePool crypto)
_ VMap VB VB (KeyHash 'StakePool crypto) (PoolParams crypto)
_) = Integer
activeStake
  where
    Coin Integer
activeStake = Map (Credential 'Staking crypto) Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ((CompactForm Coin -> Coin)
-> Map (Credential 'Staking crypto) (CompactForm Coin)
-> Map (Credential 'Staking crypto) Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
-> Map (Credential 'Staking crypto) (CompactForm Coin)
forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
VMap kv vv k v -> Map k v
VMap.toMap (Stake crypto
-> VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
forall crypto.
Stake crypto
-> VMap VB VP (Credential 'Staking crypto) (CompactForm Coin)
unStake Stake crypto
stake)))

-- | This function obtains the pool parameters, equivalent to the following jq query on the output of query ledger-state
--   .nesEs.esLState._delegationState._pstate._pParams.<pool_id>
writePoolParams :: forall era ledgerera. ()
  => ShelleyLedgerEra era ~ ledgerera
  => FromCBOR (DebugLedgerState era)
  => Crypto.Crypto (Era.Crypto ledgerera)
  => Era.Crypto ledgerera ~ StandardCrypto
  => PoolId
  -> SerialisedDebugLedgerState era
  -> ExceptT ShelleyQueryCmdError IO ()
writePoolParams :: Hash StakePoolKey
-> SerialisedDebugLedgerState era
-> ExceptT ShelleyQueryCmdError IO ()
writePoolParams (StakePoolKeyHash hk) SerialisedDebugLedgerState era
qState =
  case SerialisedDebugLedgerState era
-> Either ByteString (DebugLedgerState era)
forall era.
FromCBOR (DebugLedgerState era) =>
SerialisedDebugLedgerState era
-> Either ByteString (DebugLedgerState era)
decodeDebugLedgerState SerialisedDebugLedgerState era
qState of
    -- In the event of decode failure print the CBOR instead
    Left ByteString
bs -> (HelpersError -> ShelleyQueryCmdError)
-> ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT HelpersError -> ShelleyQueryCmdError
ShelleyQueryCmdHelpersError (ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ExceptT HelpersError IO ()
pPrintCBOR ByteString
bs

    Right DebugLedgerState era
ledgerState -> do
      let DebugLedgerState NewEpochState ledgerera
snapshot = DebugLedgerState era
ledgerState

      let poolState :: PState StandardCrypto
          poolState :: PState StandardCrypto
poolState = DPState StandardCrypto -> PState StandardCrypto
forall crypto. DPState crypto -> PState crypto
dpsPState (DPState StandardCrypto -> PState StandardCrypto)
-> (LedgerState ledgerera -> DPState StandardCrypto)
-> LedgerState ledgerera
-> PState StandardCrypto
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LedgerState ledgerera -> DPState StandardCrypto
forall era. LedgerState era -> DPState (Crypto era)
lsDPState (LedgerState ledgerera -> PState StandardCrypto)
-> LedgerState ledgerera -> PState StandardCrypto
forall a b. (a -> b) -> a -> b
$ EpochState ledgerera -> LedgerState ledgerera
forall era. EpochState era -> LedgerState era
esLState (EpochState ledgerera -> LedgerState ledgerera)
-> EpochState ledgerera -> LedgerState ledgerera
forall a b. (a -> b) -> a -> b
$ NewEpochState ledgerera -> EpochState ledgerera
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState ledgerera
snapshot

      -- Pool parameters
      let poolParams :: Maybe (PoolParams StandardCrypto)
poolParams = KeyHash 'StakePool StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto) (PoolParams StandardCrypto)
-> Maybe (PoolParams StandardCrypto)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool StandardCrypto
hk (Map
   (KeyHash 'StakePool StandardCrypto) (PoolParams StandardCrypto)
 -> Maybe (PoolParams StandardCrypto))
-> Map
     (KeyHash 'StakePool StandardCrypto) (PoolParams StandardCrypto)
-> Maybe (PoolParams StandardCrypto)
forall a b. (a -> b) -> a -> b
$ PState StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto) (PoolParams StandardCrypto)
forall crypto.
PState crypto
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_pParams PState StandardCrypto
poolState
      let fPoolParams :: Maybe (PoolParams StandardCrypto)
fPoolParams = KeyHash 'StakePool StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto) (PoolParams StandardCrypto)
-> Maybe (PoolParams StandardCrypto)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool StandardCrypto
hk (Map
   (KeyHash 'StakePool StandardCrypto) (PoolParams StandardCrypto)
 -> Maybe (PoolParams StandardCrypto))
-> Map
     (KeyHash 'StakePool StandardCrypto) (PoolParams StandardCrypto)
-> Maybe (PoolParams StandardCrypto)
forall a b. (a -> b) -> a -> b
$ PState StandardCrypto
-> Map
     (KeyHash 'StakePool StandardCrypto) (PoolParams StandardCrypto)
forall crypto.
PState crypto
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_fPParams PState StandardCrypto
poolState
      let retiring :: Maybe EpochNo
retiring = KeyHash 'StakePool StandardCrypto
-> Map (KeyHash 'StakePool StandardCrypto) EpochNo -> Maybe EpochNo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool StandardCrypto
hk (Map (KeyHash 'StakePool StandardCrypto) EpochNo -> Maybe EpochNo)
-> Map (KeyHash 'StakePool StandardCrypto) EpochNo -> Maybe EpochNo
forall a b. (a -> b) -> a -> b
$ PState StandardCrypto
-> Map (KeyHash 'StakePool StandardCrypto) EpochNo
forall crypto.
PState crypto -> Map (KeyHash 'StakePool crypto) EpochNo
_retiring PState StandardCrypto
poolState

      IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> (ByteString -> IO ())
-> ByteString
-> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> IO ()
LBS.putStrLn (ByteString -> ExceptT ShelleyQueryCmdError IO ())
-> ByteString -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ Params StandardCrypto -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (Params StandardCrypto -> ByteString)
-> Params StandardCrypto -> ByteString
forall a b. (a -> b) -> a -> b
$ Maybe (PoolParams StandardCrypto)
-> Maybe (PoolParams StandardCrypto)
-> Maybe EpochNo
-> Params StandardCrypto
forall crypto.
Maybe (PoolParams crypto)
-> Maybe (PoolParams crypto) -> Maybe EpochNo -> Params crypto
Params Maybe (PoolParams StandardCrypto)
poolParams Maybe (PoolParams StandardCrypto)
fPoolParams Maybe EpochNo
retiring

writeProtocolState ::
  ( FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
  , ToJSON (Consensus.ChainDepState (ConsensusProtocol era))
  )
  => Maybe OutputFile
  -> ProtocolState era
  -> ExceptT ShelleyQueryCmdError IO ()
writeProtocolState :: Maybe OutputFile
-> ProtocolState era -> ExceptT ShelleyQueryCmdError IO ()
writeProtocolState Maybe OutputFile
mOutFile ps :: ProtocolState era
ps@(ProtocolState Serialised (ChainDepState (ConsensusProtocol era))
pstate) =
  case Maybe OutputFile
mOutFile of
    Maybe OutputFile
Nothing -> case ProtocolState era
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
forall era.
FromCBOR (ChainDepState (ConsensusProtocol era)) =>
ProtocolState era
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
decodeProtocolState ProtocolState era
ps of
      Left (ByteString
bs, DecoderError
_) -> (HelpersError -> ShelleyQueryCmdError)
-> ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT HelpersError -> ShelleyQueryCmdError
ShelleyQueryCmdHelpersError (ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT HelpersError IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ExceptT HelpersError IO ()
pPrintCBOR ByteString
bs
      Right ChainDepState (ConsensusProtocol era)
chainDepstate -> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> (ByteString -> IO ())
-> ByteString
-> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> IO ()
LBS.putStrLn (ByteString -> ExceptT ShelleyQueryCmdError IO ())
-> ByteString -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ChainDepState (ConsensusProtocol era) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty ChainDepState (ConsensusProtocol era)
chainDepstate
    Just (OutputFile String
fpath) ->
      (IOException -> ShelleyQueryCmdError)
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError (FileError () -> ShelleyQueryCmdError)
-> (IOException -> FileError ())
-> IOException
-> ShelleyQueryCmdError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IOException -> FileError ()
forall e. String -> IOException -> FileError e
FileIOError String
fpath)
        (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> (ByteString -> IO ())
-> ByteString
-> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> ByteString -> IO ()
LBS.writeFile String
fpath (ByteString -> ExceptT ShelleyQueryCmdError IO ())
-> ByteString -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ Serialised (ChainDepState (ConsensusProtocol era)) -> ByteString
forall a. Serialised a -> ByteString
unSerialised Serialised (ChainDepState (ConsensusProtocol era))
pstate

writeFilteredUTxOs :: Api.ShelleyBasedEra era
                   -> Maybe OutputFile
                   -> UTxO era
                   -> ExceptT ShelleyQueryCmdError IO ()
writeFilteredUTxOs :: ShelleyBasedEra era
-> Maybe OutputFile
-> UTxO era
-> ExceptT ShelleyQueryCmdError IO ()
writeFilteredUTxOs ShelleyBasedEra era
shelleyBasedEra' Maybe OutputFile
mOutFile UTxO era
utxo =
    case Maybe OutputFile
mOutFile of
      Maybe OutputFile
Nothing -> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> UTxO era -> IO ()
forall era. ShelleyBasedEra era -> UTxO era -> IO ()
printFilteredUTxOs ShelleyBasedEra era
shelleyBasedEra' UTxO era
utxo
      Just (OutputFile String
fpath) ->
        case ShelleyBasedEra era
shelleyBasedEra' of
          ShelleyBasedEra era
ShelleyBasedEraShelley -> String -> UTxO era -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
String -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo String
fpath UTxO era
utxo
          ShelleyBasedEra era
ShelleyBasedEraAllegra -> String -> UTxO era -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
String -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo String
fpath UTxO era
utxo
          ShelleyBasedEra era
ShelleyBasedEraMary -> String -> UTxO era -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
String -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo String
fpath UTxO era
utxo
          ShelleyBasedEra era
ShelleyBasedEraAlonzo -> String -> UTxO era -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
String -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo String
fpath UTxO era
utxo
          ShelleyBasedEra era
ShelleyBasedEraBabbage -> String -> UTxO era -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a.
(MonadIO m, ToJSON a) =>
String -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo String
fpath UTxO era
utxo
 where
   writeUTxo :: String -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo String
fpath a
utxo' =
     (IOException -> ShelleyQueryCmdError)
-> IO () -> ExceptT ShelleyQueryCmdError m ()
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError (FileError () -> ShelleyQueryCmdError)
-> (IOException -> FileError ())
-> IOException
-> ShelleyQueryCmdError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IOException -> FileError ()
forall e. String -> IOException -> FileError e
FileIOError String
fpath)
       (IO () -> ExceptT ShelleyQueryCmdError m ())
-> IO () -> ExceptT ShelleyQueryCmdError m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LBS.writeFile String
fpath (a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty a
utxo')

printFilteredUTxOs :: Api.ShelleyBasedEra era -> UTxO era -> IO ()
printFilteredUTxOs :: ShelleyBasedEra era -> UTxO era -> IO ()
printFilteredUTxOs ShelleyBasedEra era
shelleyBasedEra' (UTxO Map TxIn (TxOut CtxUTxO era)
utxo) = do
  Text -> IO ()
Text.putStrLn Text
title
  String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Text -> Int
Text.length Text
title Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Char
'-'
  case ShelleyBasedEra era
shelleyBasedEra' of
    ShelleyBasedEra era
ShelleyBasedEraShelley ->
      ((TxIn, TxOut CtxUTxO era) -> IO ())
-> [(TxIn, TxOut CtxUTxO era)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
forall era.
ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra') ([(TxIn, TxOut CtxUTxO era)] -> IO ())
-> [(TxIn, TxOut CtxUTxO era)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO era) -> [(TxIn, TxOut CtxUTxO era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO era)
utxo
    ShelleyBasedEra era
ShelleyBasedEraAllegra ->
      ((TxIn, TxOut CtxUTxO era) -> IO ())
-> [(TxIn, TxOut CtxUTxO era)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
forall era.
ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra') ([(TxIn, TxOut CtxUTxO era)] -> IO ())
-> [(TxIn, TxOut CtxUTxO era)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO era) -> [(TxIn, TxOut CtxUTxO era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO era)
utxo
    ShelleyBasedEra era
ShelleyBasedEraMary    ->
      ((TxIn, TxOut CtxUTxO era) -> IO ())
-> [(TxIn, TxOut CtxUTxO era)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
forall era.
ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra') ([(TxIn, TxOut CtxUTxO era)] -> IO ())
-> [(TxIn, TxOut CtxUTxO era)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO era) -> [(TxIn, TxOut CtxUTxO era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO era)
utxo
    ShelleyBasedEra era
ShelleyBasedEraAlonzo ->
      ((TxIn, TxOut CtxUTxO era) -> IO ())
-> [(TxIn, TxOut CtxUTxO era)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
forall era.
ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra') ([(TxIn, TxOut CtxUTxO era)] -> IO ())
-> [(TxIn, TxOut CtxUTxO era)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO era) -> [(TxIn, TxOut CtxUTxO era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO era)
utxo
    ShelleyBasedEra era
ShelleyBasedEraBabbage ->
      ((TxIn, TxOut CtxUTxO era) -> IO ())
-> [(TxIn, TxOut CtxUTxO era)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
forall era.
ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra') ([(TxIn, TxOut CtxUTxO era)] -> IO ())
-> [(TxIn, TxOut CtxUTxO era)] -> IO ()
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO era) -> [(TxIn, TxOut CtxUTxO era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO era)
utxo

 where
   title :: Text
   title :: Text
title =
     Text
"                           TxHash                                 TxIx        Amount"

printUtxo
  :: Api.ShelleyBasedEra era
  -> (TxIn, TxOut CtxUTxO era)
  -> IO ()
printUtxo :: ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra' (TxIn, TxOut CtxUTxO era)
txInOutTuple =
  case ShelleyBasedEra era
shelleyBasedEra' of
    ShelleyBasedEra era
ShelleyBasedEraShelley ->
      let (TxIn (TxId Hash StandardCrypto EraIndependentTxBody
txhash) (TxIx Word
index), TxOut AddressInEra era
_ TxOutValue era
value TxOutDatum CtxUTxO era
_ ReferenceScript era
_) = (TxIn, TxOut CtxUTxO era)
txInOutTuple
      in Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
           [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> Text
Text.decodeLatin1 (Hash Blake2b_256 EraIndependentTxBody -> ByteString
forall h a. Hash h a -> ByteString
hashToBytesAsHex Hash StandardCrypto EraIndependentTxBody
Hash Blake2b_256 EraIndependentTxBody
txhash)
             , Int -> Word -> Text
forall a. Show a => Int -> a -> Text
textShowN Int
6 Word
index
             , Text
"        " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxOutValue era -> Text
forall era. TxOutValue era -> Text
printableValue TxOutValue era
value
             ]

    ShelleyBasedEra era
ShelleyBasedEraAllegra ->
      let (TxIn (TxId Hash StandardCrypto EraIndependentTxBody
txhash) (TxIx Word
index), TxOut AddressInEra era
_ TxOutValue era
value TxOutDatum CtxUTxO era
_ ReferenceScript era
_) = (TxIn, TxOut CtxUTxO era)
txInOutTuple
      in Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
           [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> Text
Text.decodeLatin1 (Hash Blake2b_256 EraIndependentTxBody -> ByteString
forall h a. Hash h a -> ByteString
hashToBytesAsHex Hash StandardCrypto EraIndependentTxBody
Hash Blake2b_256 EraIndependentTxBody
txhash)
             , Int -> Word -> Text
forall a. Show a => Int -> a -> Text
textShowN Int
6 Word
index
             , Text
"        " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxOutValue era -> Text
forall era. TxOutValue era -> Text
printableValue TxOutValue era
value
             ]
    ShelleyBasedEra era
ShelleyBasedEraMary ->
      let (TxIn (TxId Hash StandardCrypto EraIndependentTxBody
txhash) (TxIx Word
index), TxOut AddressInEra era
_ TxOutValue era
value TxOutDatum CtxUTxO era
_ ReferenceScript era
_) = (TxIn, TxOut CtxUTxO era)
txInOutTuple
      in Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
           [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> Text
Text.decodeLatin1 (Hash Blake2b_256 EraIndependentTxBody -> ByteString
forall h a. Hash h a -> ByteString
hashToBytesAsHex Hash StandardCrypto EraIndependentTxBody
Hash Blake2b_256 EraIndependentTxBody
txhash)
             , Int -> Word -> Text
forall a. Show a => Int -> a -> Text
textShowN Int
6 Word
index
             , Text
"        " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxOutValue era -> Text
forall era. TxOutValue era -> Text
printableValue TxOutValue era
value
             ]
    ShelleyBasedEra era
ShelleyBasedEraAlonzo ->
      let (TxIn (TxId Hash StandardCrypto EraIndependentTxBody
txhash) (TxIx Word
index), TxOut AddressInEra era
_ TxOutValue era
value TxOutDatum CtxUTxO era
mDatum ReferenceScript era
_) = (TxIn, TxOut CtxUTxO era)
txInOutTuple
      in Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
           [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> Text
Text.decodeLatin1 (Hash Blake2b_256 EraIndependentTxBody -> ByteString
forall h a. Hash h a -> ByteString
hashToBytesAsHex Hash StandardCrypto EraIndependentTxBody
Hash Blake2b_256 EraIndependentTxBody
txhash)
             , Int -> Word -> Text
forall a. Show a => Int -> a -> Text
textShowN Int
6 Word
index
             , Text
"        " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxOutValue era -> Text
forall era. TxOutValue era -> Text
printableValue TxOutValue era
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" + " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (TxOutDatum CtxUTxO era -> String
forall a b. (Show a, ConvertText String b) => a -> b
show TxOutDatum CtxUTxO era
mDatum)
             ]
    ShelleyBasedEra era
ShelleyBasedEraBabbage ->
      let (TxIn (TxId Hash StandardCrypto EraIndependentTxBody
txhash) (TxIx Word
index), TxOut AddressInEra era
_ TxOutValue era
value TxOutDatum CtxUTxO era
mDatum ReferenceScript era
_) = (TxIn, TxOut CtxUTxO era)
txInOutTuple
      in Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
           [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> Text
Text.decodeLatin1 (Hash Blake2b_256 EraIndependentTxBody -> ByteString
forall h a. Hash h a -> ByteString
hashToBytesAsHex Hash StandardCrypto EraIndependentTxBody
Hash Blake2b_256 EraIndependentTxBody
txhash)
             , Int -> Word -> Text
forall a. Show a => Int -> a -> Text
textShowN Int
6 Word
index
             , Text
"        " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxOutValue era -> Text
forall era. TxOutValue era -> Text
printableValue TxOutValue era
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" + " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (TxOutDatum CtxUTxO era -> String
forall a b. (Show a, ConvertText String b) => a -> b
show TxOutDatum CtxUTxO era
mDatum)
             ]
 where
  textShowN :: Show a => Int -> a -> Text
  textShowN :: Int -> a -> Text
textShowN Int
len a
x =
    let str :: String
str = a -> String
forall a b. (Show a, ConvertText String b) => a -> b
show a
x
        slen :: Int
slen = String -> Int
forall a. HasLength a => a -> Int
length String
str
    in String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
slen)) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str

  printableValue :: TxOutValue era -> Text
  printableValue :: TxOutValue era -> Text
printableValue (TxOutValue MultiAssetSupportedInEra era
_ Value
val) = Value -> Text
renderValue Value
val
  printableValue (TxOutAdaOnly OnlyAdaSupportedInEra era
_ (Lovelace Integer
i)) = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Integer
i

runQueryStakePools
  :: AnyConsensusModeParams
  -> NetworkId
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryStakePools :: AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryStakePools (AnyConsensusModeParams ConsensusModeParams mode
cModeParams)
                          NetworkId
network Maybe OutputFile
mOutFile = do
  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr ExceptT EnvSocketError IO SocketPath
readEnvSocketPath

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

  Set (Hash StakePoolKey)
result <- IO (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
-> ExceptT ShelleyQueryCmdError IO (Set (Hash StakePoolKey))
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
 -> ExceptT ShelleyQueryCmdError IO (Set (Hash StakePoolKey)))
-> (IO
      (Either
         AcquireFailure
         (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
    -> IO (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
-> IO
     (Either
        AcquireFailure
        (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
-> ExceptT ShelleyQueryCmdError IO (Set (Hash StakePoolKey))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Either
   AcquireFailure
   (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
 -> Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
-> IO
     (Either
        AcquireFailure
        (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
-> IO (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either
  ShelleyQueryCmdError
  (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
-> Either ShelleyQueryCmdError (Set (Hash StakePoolKey))
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Either
   ShelleyQueryCmdError
   (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
 -> Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
-> (Either
      AcquireFailure
      (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
    -> Either
         ShelleyQueryCmdError
         (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
-> Either
     AcquireFailure
     (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
-> Either ShelleyQueryCmdError (Set (Hash StakePoolKey))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (AcquireFailure -> ShelleyQueryCmdError)
-> Either
     AcquireFailure
     (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
-> Either
     ShelleyQueryCmdError
     (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first AcquireFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure) (IO
   (Either
      AcquireFailure
      (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
 -> ExceptT ShelleyQueryCmdError IO (Set (Hash StakePoolKey)))
-> IO
     (Either
        AcquireFailure
        (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
-> ExceptT ShelleyQueryCmdError IO (Set (Hash StakePoolKey))
forall a b. (a -> b) -> a -> b
$
    LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> (NodeToClientVersion
    -> LocalStateQueryExpr
         (BlockInMode mode)
         ChainPoint
         (QueryInMode mode)
         ()
         IO
         (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
-> IO
     (Either
        AcquireFailure
        (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
forall mode a.
LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> (NodeToClientVersion
    -> LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO a)
-> IO (Either AcquireFailure a)
executeLocalStateQueryExpr LocalNodeConnectInfo mode
localNodeConnInfo Maybe ChainPoint
forall a. Maybe a
Nothing ((NodeToClientVersion
  -> LocalStateQueryExpr
       (BlockInMode mode)
       ChainPoint
       (QueryInMode mode)
       ()
       IO
       (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
 -> IO
      (Either
         AcquireFailure
         (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))))
-> (NodeToClientVersion
    -> LocalStateQueryExpr
         (BlockInMode mode)
         ChainPoint
         (QueryInMode mode)
         ()
         IO
         (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
-> IO
     (Either
        AcquireFailure
        (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
forall a b. (a -> b) -> a -> b
$ \NodeToClientVersion
_ntcVersion -> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
forall (m :: * -> *) a.
ExceptT ShelleyQueryCmdError m a
-> m (Either ShelleyQueryCmdError a)
runExceptT @ShelleyQueryCmdError (ExceptT
   ShelleyQueryCmdError
   (LocalStateQueryExpr
      (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
   (Set (Hash StakePoolKey))
 -> LocalStateQueryExpr
      (BlockInMode mode)
      ChainPoint
      (QueryInMode mode)
      ()
      IO
      (Either ShelleyQueryCmdError (Set (Hash StakePoolKey))))
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (Set (Hash StakePoolKey))
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Either ShelleyQueryCmdError (Set (Hash StakePoolKey)))
forall a b. (a -> b) -> a -> b
$ do
      anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- case ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams of
        ConsensusMode mode
ByronMode -> AnyCardanoEra
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     AnyCardanoEra
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyCardanoEra
 -> ExceptT
      ShelleyQueryCmdError
      (LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
      AnyCardanoEra)
-> AnyCardanoEra
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     AnyCardanoEra
forall a b. (a -> b) -> a -> b
$ CardanoEra ByronEra -> AnyCardanoEra
forall era. IsCardanoEra era => CardanoEra era -> AnyCardanoEra
AnyCardanoEra CardanoEra ByronEra
ByronEra
        ConsensusMode mode
ShelleyMode -> AnyCardanoEra
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     AnyCardanoEra
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyCardanoEra
 -> ExceptT
      ShelleyQueryCmdError
      (LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
      AnyCardanoEra)
-> AnyCardanoEra
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     AnyCardanoEra
forall a b. (a -> b) -> a -> b
$ CardanoEra ShelleyEra -> AnyCardanoEra
forall era. IsCardanoEra era => CardanoEra era -> AnyCardanoEra
AnyCardanoEra CardanoEra ShelleyEra
ShelleyEra
        ConsensusMode mode
CardanoMode -> LocalStateQueryExpr
  (BlockInMode CardanoMode)
  ChainPoint
  (QueryInMode CardanoMode)
  ()
  IO
  AnyCardanoEra
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode CardanoMode)
        ChainPoint
        (QueryInMode CardanoMode)
        ()
        IO)
     AnyCardanoEra
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LocalStateQueryExpr
   (BlockInMode CardanoMode)
   ChainPoint
   (QueryInMode CardanoMode)
   ()
   IO
   AnyCardanoEra
 -> ExceptT
      ShelleyQueryCmdError
      (LocalStateQueryExpr
         (BlockInMode CardanoMode)
         ChainPoint
         (QueryInMode CardanoMode)
         ()
         IO)
      AnyCardanoEra)
-> (QueryInMode CardanoMode AnyCardanoEra
    -> LocalStateQueryExpr
         (BlockInMode CardanoMode)
         ChainPoint
         (QueryInMode CardanoMode)
         ()
         IO
         AnyCardanoEra)
-> QueryInMode CardanoMode AnyCardanoEra
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode CardanoMode)
        ChainPoint
        (QueryInMode CardanoMode)
        ()
        IO)
     AnyCardanoEra
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. QueryInMode CardanoMode AnyCardanoEra
-> LocalStateQueryExpr
     (BlockInMode CardanoMode)
     ChainPoint
     (QueryInMode CardanoMode)
     ()
     IO
     AnyCardanoEra
forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr block point (QueryInMode mode) r IO a
queryExpr (QueryInMode CardanoMode AnyCardanoEra
 -> ExceptT
      ShelleyQueryCmdError
      (LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
      AnyCardanoEra)
-> QueryInMode CardanoMode AnyCardanoEra
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     AnyCardanoEra
forall a b. (a -> b) -> a -> b
$ ConsensusModeIsMultiEra CardanoMode
-> QueryInMode CardanoMode AnyCardanoEra
forall mode.
ConsensusModeIsMultiEra mode -> QueryInMode mode AnyCardanoEra
QueryCurrentEra ConsensusModeIsMultiEra CardanoMode
CardanoModeIsMultiEra

      let cMode :: ConsensusMode mode
cMode = ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams

      case CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode of
        Just EraInMode era mode
eInMode -> do
          ShelleyBasedEra era
sbe <- CardanoEraStyle era
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (ShelleyBasedEra era)
forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe (CardanoEraStyle era
 -> ExceptT
      ShelleyQueryCmdError
      (LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
      (ShelleyBasedEra era))
-> CardanoEraStyle era
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (ShelleyBasedEra era)
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> CardanoEraStyle era
forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era

          (EraMismatch -> ShelleyQueryCmdError)
-> ExceptT
     EraMismatch
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (Set (Hash StakePoolKey))
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (Set (Hash StakePoolKey))
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EraMismatch -> ShelleyQueryCmdError
ShelleyQueryCmdEraMismatch (ExceptT
   EraMismatch
   (LocalStateQueryExpr
      (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
   (Set (Hash StakePoolKey))
 -> ExceptT
      ShelleyQueryCmdError
      (LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
      (Set (Hash StakePoolKey)))
-> (LocalStateQueryExpr
      (BlockInMode mode)
      ChainPoint
      (QueryInMode mode)
      ()
      IO
      (Either EraMismatch (Set (Hash StakePoolKey)))
    -> ExceptT
         EraMismatch
         (LocalStateQueryExpr
            (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
         (Set (Hash StakePoolKey)))
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Either EraMismatch (Set (Hash StakePoolKey)))
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (Set (Hash StakePoolKey))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LocalStateQueryExpr
  (BlockInMode mode)
  ChainPoint
  (QueryInMode mode)
  ()
  IO
  (Either EraMismatch (Set (Hash StakePoolKey)))
-> ExceptT
     EraMismatch
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (Set (Hash StakePoolKey))
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (LocalStateQueryExpr
   (BlockInMode mode)
   ChainPoint
   (QueryInMode mode)
   ()
   IO
   (Either EraMismatch (Set (Hash StakePoolKey)))
 -> ExceptT
      ShelleyQueryCmdError
      (LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
      (Set (Hash StakePoolKey)))
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Either EraMismatch (Set (Hash StakePoolKey)))
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (Set (Hash StakePoolKey))
forall a b. (a -> b) -> a -> b
$
            QueryInMode mode (Either EraMismatch (Set (Hash StakePoolKey)))
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Either EraMismatch (Set (Hash StakePoolKey)))
forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr block point (QueryInMode mode) r IO a
queryExpr (QueryInMode mode (Either EraMismatch (Set (Hash StakePoolKey)))
 -> LocalStateQueryExpr
      (BlockInMode mode)
      ChainPoint
      (QueryInMode mode)
      ()
      IO
      (Either EraMismatch (Set (Hash StakePoolKey))))
-> (QueryInShelleyBasedEra era (Set (Hash StakePoolKey))
    -> QueryInMode mode (Either EraMismatch (Set (Hash StakePoolKey))))
-> QueryInShelleyBasedEra era (Set (Hash StakePoolKey))
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Either EraMismatch (Set (Hash StakePoolKey)))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. EraInMode era mode
-> QueryInEra era (Set (Hash StakePoolKey))
-> QueryInMode mode (Either EraMismatch (Set (Hash StakePoolKey)))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era (Set (Hash StakePoolKey))
 -> QueryInMode mode (Either EraMismatch (Set (Hash StakePoolKey))))
-> (QueryInShelleyBasedEra era (Set (Hash StakePoolKey))
    -> QueryInEra era (Set (Hash StakePoolKey)))
-> QueryInShelleyBasedEra era (Set (Hash StakePoolKey))
-> QueryInMode mode (Either EraMismatch (Set (Hash StakePoolKey)))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShelleyBasedEra era
-> QueryInShelleyBasedEra era (Set (Hash StakePoolKey))
-> QueryInEra era (Set (Hash StakePoolKey))
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe (QueryInShelleyBasedEra era (Set (Hash StakePoolKey))
 -> LocalStateQueryExpr
      (BlockInMode mode)
      ChainPoint
      (QueryInMode mode)
      ()
      IO
      (Either EraMismatch (Set (Hash StakePoolKey))))
-> QueryInShelleyBasedEra era (Set (Hash StakePoolKey))
-> LocalStateQueryExpr
     (BlockInMode mode)
     ChainPoint
     (QueryInMode mode)
     ()
     IO
     (Either EraMismatch (Set (Hash StakePoolKey)))
forall a b. (a -> b) -> a -> b
$ QueryInShelleyBasedEra era (Set (Hash StakePoolKey))
forall era. QueryInShelleyBasedEra era (Set (Hash StakePoolKey))
QueryStakePools

        Maybe (EraInMode era mode)
Nothing -> ShelleyQueryCmdError
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (Set (Hash StakePoolKey))
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ShelleyQueryCmdError
 -> ExceptT
      ShelleyQueryCmdError
      (LocalStateQueryExpr
         (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
      (Set (Hash StakePoolKey)))
-> ShelleyQueryCmdError
-> ExceptT
     ShelleyQueryCmdError
     (LocalStateQueryExpr
        (BlockInMode mode) ChainPoint (QueryInMode mode) () IO)
     (Set (Hash StakePoolKey))
forall a b. (a -> b) -> a -> b
$ AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE

  Maybe OutputFile
-> Set (Hash StakePoolKey) -> ExceptT ShelleyQueryCmdError IO ()
writeStakePools Maybe OutputFile
mOutFile Set (Hash StakePoolKey)
result

writeStakePools
  :: Maybe OutputFile
  -> Set PoolId
  -> ExceptT ShelleyQueryCmdError IO ()
writeStakePools :: Maybe OutputFile
-> Set (Hash StakePoolKey) -> ExceptT ShelleyQueryCmdError IO ()
writeStakePools (Just (OutputFile String
outFile)) Set (Hash StakePoolKey)
stakePools =
  (IOException -> ShelleyQueryCmdError)
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError (FileError () -> ShelleyQueryCmdError)
-> (IOException -> FileError ())
-> IOException
-> ShelleyQueryCmdError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IOException -> FileError ()
forall e. String -> IOException -> FileError e
FileIOError String
outFile) (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$
    String -> ByteString -> IO ()
LBS.writeFile String
outFile (Set (Hash StakePoolKey) -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Set (Hash StakePoolKey)
stakePools)

writeStakePools Maybe OutputFile
Nothing Set (Hash StakePoolKey)
stakePools =
  [Hash StakePoolKey]
-> (Hash StakePoolKey -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT ShelleyQueryCmdError IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set (Hash StakePoolKey) -> [Hash StakePoolKey]
forall a. Set a -> [a]
Set.toList Set (Hash StakePoolKey)
stakePools) ((Hash StakePoolKey -> ExceptT ShelleyQueryCmdError IO ())
 -> ExceptT ShelleyQueryCmdError IO ())
-> (Hash StakePoolKey -> ExceptT ShelleyQueryCmdError IO ())
-> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ \Hash StakePoolKey
poolId ->
    IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> (String -> IO ())
-> String
-> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn (String -> ExceptT ShelleyQueryCmdError IO ())
-> String -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Hash StakePoolKey -> Text
forall a. SerialiseAsBech32 a => a -> Text
serialiseToBech32 Hash StakePoolKey
poolId)

runQueryStakeDistribution
  :: AnyConsensusModeParams
  -> NetworkId
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeDistribution :: AnyConsensusModeParams
-> NetworkId
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeDistribution (AnyConsensusModeParams ConsensusModeParams mode
cModeParams)
                          NetworkId
network Maybe OutputFile
mOutFile = do
  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr ExceptT EnvSocketError IO SocketPath
readEnvSocketPath
  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo
  let cMode :: ConsensusMode mode
cMode = ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams
  ShelleyBasedEra era
sbe <- CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe (CardanoEraStyle era
 -> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era))
-> CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> CardanoEraStyle era
forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era

  case CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode of
    Just EraInMode era mode
eInMode -> do
      let query :: QueryInMode
  mode (Either EraMismatch (Map (Hash StakePoolKey) Rational))
query = EraInMode era mode
-> QueryInEra era (Map (Hash StakePoolKey) Rational)
-> QueryInMode
     mode (Either EraMismatch (Map (Hash StakePoolKey) Rational))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode
                    (QueryInEra era (Map (Hash StakePoolKey) Rational)
 -> QueryInMode
      mode (Either EraMismatch (Map (Hash StakePoolKey) Rational)))
-> (QueryInShelleyBasedEra era (Map (Hash StakePoolKey) Rational)
    -> QueryInEra era (Map (Hash StakePoolKey) Rational))
-> QueryInShelleyBasedEra era (Map (Hash StakePoolKey) Rational)
-> QueryInMode
     mode (Either EraMismatch (Map (Hash StakePoolKey) Rational))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShelleyBasedEra era
-> QueryInShelleyBasedEra era (Map (Hash StakePoolKey) Rational)
-> QueryInEra era (Map (Hash StakePoolKey) Rational)
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe
                    (QueryInShelleyBasedEra era (Map (Hash StakePoolKey) Rational)
 -> QueryInMode
      mode (Either EraMismatch (Map (Hash StakePoolKey) Rational)))
-> QueryInShelleyBasedEra era (Map (Hash StakePoolKey) Rational)
-> QueryInMode
     mode (Either EraMismatch (Map (Hash StakePoolKey) Rational))
forall a b. (a -> b) -> a -> b
$ QueryInShelleyBasedEra era (Map (Hash StakePoolKey) Rational)
forall era.
QueryInShelleyBasedEra era (Map (Hash StakePoolKey) Rational)
QueryStakeDistribution
      Map (Hash StakePoolKey) Rational
result <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode
     mode (Either EraMismatch (Map (Hash StakePoolKey) Rational))
-> ExceptT
     ShelleyQueryCmdError IO (Map (Hash StakePoolKey) Rational)
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery
                  CardanoEra era
era
                  ConsensusModeParams mode
cModeParams
                  LocalNodeConnectInfo mode
localNodeConnInfo
                  QueryInMode
  mode (Either EraMismatch (Map (Hash StakePoolKey) Rational))
query
      Maybe OutputFile
-> Map (Hash StakePoolKey) Rational
-> ExceptT ShelleyQueryCmdError IO ()
writeStakeDistribution Maybe OutputFile
mOutFile Map (Hash StakePoolKey) Rational
result
    Maybe (EraInMode era mode)
Nothing -> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE


writeStakeDistribution
  :: Maybe OutputFile
  -> Map PoolId Rational
  -> ExceptT ShelleyQueryCmdError IO ()
writeStakeDistribution :: Maybe OutputFile
-> Map (Hash StakePoolKey) Rational
-> ExceptT ShelleyQueryCmdError IO ()
writeStakeDistribution (Just (OutputFile String
outFile)) Map (Hash StakePoolKey) Rational
stakeDistrib =
  (IOException -> ShelleyQueryCmdError)
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError (FileError () -> ShelleyQueryCmdError)
-> (IOException -> FileError ())
-> IOException
-> ShelleyQueryCmdError
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> IOException -> FileError ()
forall e. String -> IOException -> FileError e
FileIOError String
outFile) (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$
    String -> ByteString -> IO ()
LBS.writeFile String
outFile (Map (Hash StakePoolKey) Rational -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty Map (Hash StakePoolKey) Rational
stakeDistrib)

writeStakeDistribution Maybe OutputFile
Nothing Map (Hash StakePoolKey) Rational
stakeDistrib =
  IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ Map (Hash StakePoolKey) Rational -> IO ()
printStakeDistribution Map (Hash StakePoolKey) Rational
stakeDistrib


printStakeDistribution :: Map PoolId Rational -> IO ()
printStakeDistribution :: Map (Hash StakePoolKey) Rational -> IO ()
printStakeDistribution Map (Hash StakePoolKey) Rational
stakeDistrib = do
  Text -> IO ()
Text.putStrLn Text
title
  String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Text -> Int
Text.length Text
title Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Char
'-'
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
    [ String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Hash StakePoolKey -> Rational -> String
showStakeDistr Hash StakePoolKey
poolId Rational
stakeFraction
    | (Hash StakePoolKey
poolId, Rational
stakeFraction) <- Map (Hash StakePoolKey) Rational -> [(Hash StakePoolKey, Rational)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Hash StakePoolKey) Rational
stakeDistrib ]
 where
   title :: Text
   title :: Text
title =
     Text
"                           PoolId                                 Stake frac"

   showStakeDistr :: PoolId
                  -> Rational
                  -- ^ Stake fraction
                  -> String
   showStakeDistr :: Hash StakePoolKey -> Rational -> String
showStakeDistr Hash StakePoolKey
poolId Rational
stakeFraction =
     [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
       [ Text -> String
Text.unpack (Hash StakePoolKey -> Text
forall a. SerialiseAsBech32 a => a -> Text
serialiseToBech32 Hash StakePoolKey
poolId)
       , String
"   "
       , Maybe Int -> Double -> ShowS
forall a. RealFloat a => Maybe Int -> a -> ShowS
showEFloat (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3) (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
stakeFraction :: Double) String
""
       ]

-- | A mapping of Shelley reward accounts to both the stake pool that they
-- delegate to and their reward account balance.
-- TODO: Move to cardano-api
newtype DelegationsAndRewards
  = DelegationsAndRewards (Map StakeAddress Lovelace, Map StakeAddress PoolId)
    deriving (DelegationsAndRewards -> DelegationsAndRewards -> Bool
(DelegationsAndRewards -> DelegationsAndRewards -> Bool)
-> (DelegationsAndRewards -> DelegationsAndRewards -> Bool)
-> Eq DelegationsAndRewards
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DelegationsAndRewards -> DelegationsAndRewards -> Bool
$c/= :: DelegationsAndRewards -> DelegationsAndRewards -> Bool
== :: DelegationsAndRewards -> DelegationsAndRewards -> Bool
$c== :: DelegationsAndRewards -> DelegationsAndRewards -> Bool
Eq, Int -> DelegationsAndRewards -> ShowS
[DelegationsAndRewards] -> ShowS
DelegationsAndRewards -> String
(Int -> DelegationsAndRewards -> ShowS)
-> (DelegationsAndRewards -> String)
-> ([DelegationsAndRewards] -> ShowS)
-> Show DelegationsAndRewards
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DelegationsAndRewards] -> ShowS
$cshowList :: [DelegationsAndRewards] -> ShowS
show :: DelegationsAndRewards -> String
$cshow :: DelegationsAndRewards -> String
showsPrec :: Int -> DelegationsAndRewards -> ShowS
$cshowsPrec :: Int -> DelegationsAndRewards -> ShowS
Show)


mergeDelegsAndRewards :: DelegationsAndRewards -> [(StakeAddress, Maybe Lovelace, Maybe PoolId)]
mergeDelegsAndRewards :: DelegationsAndRewards
-> [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
mergeDelegsAndRewards (DelegationsAndRewards (Map StakeAddress Lovelace
rewardsMap, Map StakeAddress (Hash StakePoolKey)
delegMap)) =
 [ (StakeAddress
stakeAddr, StakeAddress -> Map StakeAddress Lovelace -> Maybe Lovelace
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup StakeAddress
stakeAddr Map StakeAddress Lovelace
rewardsMap, StakeAddress
-> Map StakeAddress (Hash StakePoolKey)
-> Maybe (Hash StakePoolKey)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup StakeAddress
stakeAddr Map StakeAddress (Hash StakePoolKey)
delegMap)
 | StakeAddress
stakeAddr <- [StakeAddress] -> [StakeAddress]
forall a. Eq a => [a] -> [a]
nub ([StakeAddress] -> [StakeAddress])
-> [StakeAddress] -> [StakeAddress]
forall a b. (a -> b) -> a -> b
$ Map StakeAddress Lovelace -> [StakeAddress]
forall k a. Map k a -> [k]
Map.keys Map StakeAddress Lovelace
rewardsMap [StakeAddress] -> [StakeAddress] -> [StakeAddress]
forall a. [a] -> [a] -> [a]
++ Map StakeAddress (Hash StakePoolKey) -> [StakeAddress]
forall k a. Map k a -> [k]
Map.keys Map StakeAddress (Hash StakePoolKey)
delegMap
 ]


instance ToJSON DelegationsAndRewards where
  toJSON :: DelegationsAndRewards -> Value
toJSON DelegationsAndRewards
delegsAndRwds =
      Array -> Value
Aeson.Array (Array -> Value)
-> ([(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
    -> Array)
-> [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
-> Value
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList
        ([Value] -> Array)
-> ([(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
    -> [Value])
-> [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
-> Array
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))
 -> Value)
-> [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
-> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey)) -> Value
delegAndRwdToJson ([(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
 -> Value)
-> [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
-> Value
forall a b. (a -> b) -> a -> b
$ DelegationsAndRewards
-> [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
mergeDelegsAndRewards DelegationsAndRewards
delegsAndRwds
    where
      delegAndRwdToJson :: (StakeAddress, Maybe Lovelace, Maybe PoolId) -> Aeson.Value
      delegAndRwdToJson :: (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey)) -> Value
delegAndRwdToJson (StakeAddress
addr, Maybe Lovelace
mRewards, Maybe (Hash StakePoolKey)
mPoolId) =
        [Pair] -> Value
Aeson.object
          [ Key
"address" Key -> StakeAddress -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= StakeAddress
addr
          , Key
"delegation" Key -> Maybe (Hash StakePoolKey) -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe (Hash StakePoolKey)
mPoolId
          , Key
"rewardAccountBalance" Key -> Maybe Lovelace -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Lovelace
mRewards
          ]

instance FromJSON DelegationsAndRewards where
  parseJSON :: Value -> Parser DelegationsAndRewards
parseJSON = String
-> (Array -> Parser DelegationsAndRewards)
-> Value
-> Parser DelegationsAndRewards
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray String
"DelegationsAndRewards" ((Array -> Parser DelegationsAndRewards)
 -> Value -> Parser DelegationsAndRewards)
-> (Array -> Parser DelegationsAndRewards)
-> Value
-> Parser DelegationsAndRewards
forall a b. (a -> b) -> a -> b
$ \Array
arr -> do
    let vals :: [Value]
vals = Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
arr
    [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
decoded <- (Value
 -> Parser
      (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey)))
-> [Value]
-> Parser
     [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value
-> Parser (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))
decodeObject [Value]
vals
    DelegationsAndRewards -> Parser DelegationsAndRewards
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DelegationsAndRewards -> Parser DelegationsAndRewards)
-> DelegationsAndRewards -> Parser DelegationsAndRewards
forall a b. (a -> b) -> a -> b
$ [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
-> DelegationsAndRewards
zipper [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
decoded
   where
     zipper :: [(StakeAddress, Maybe Lovelace, Maybe PoolId)]
             -> DelegationsAndRewards
     zipper :: [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
-> DelegationsAndRewards
zipper [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
l = do
       let maps :: [(Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))]
maps = [ ( Map StakeAddress Lovelace
-> (Lovelace -> Map StakeAddress Lovelace)
-> Maybe Lovelace
-> Map StakeAddress Lovelace
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map StakeAddress Lovelace
forall a. Monoid a => a
mempty (StakeAddress -> Lovelace -> Map StakeAddress Lovelace
forall k a. k -> a -> Map k a
Map.singleton StakeAddress
sa) Maybe Lovelace
delegAmt
                    , Map StakeAddress (Hash StakePoolKey)
-> (Hash StakePoolKey -> Map StakeAddress (Hash StakePoolKey))
-> Maybe (Hash StakePoolKey)
-> Map StakeAddress (Hash StakePoolKey)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map StakeAddress (Hash StakePoolKey)
forall a. Monoid a => a
mempty (StakeAddress
-> Hash StakePoolKey -> Map StakeAddress (Hash StakePoolKey)
forall k a. k -> a -> Map k a
Map.singleton StakeAddress
sa) Maybe (Hash StakePoolKey)
mPool
                    )
                  | (StakeAddress
sa, Maybe Lovelace
delegAmt, Maybe (Hash StakePoolKey)
mPool) <- [(StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))]
l
                  ]
       (Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
-> DelegationsAndRewards
DelegationsAndRewards
         ((Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
 -> DelegationsAndRewards)
-> (Map StakeAddress Lovelace,
    Map StakeAddress (Hash StakePoolKey))
-> DelegationsAndRewards
forall a b. (a -> b) -> a -> b
$ ((Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))
 -> (Map StakeAddress Lovelace,
     Map StakeAddress (Hash StakePoolKey))
 -> (Map StakeAddress Lovelace,
     Map StakeAddress (Hash StakePoolKey)))
-> (Map StakeAddress Lovelace,
    Map StakeAddress (Hash StakePoolKey))
-> [(Map StakeAddress Lovelace,
     Map StakeAddress (Hash StakePoolKey))]
-> (Map StakeAddress Lovelace,
    Map StakeAddress (Hash StakePoolKey))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
             (\(Map StakeAddress Lovelace
amtA, Map StakeAddress (Hash StakePoolKey)
delegA) (Map StakeAddress Lovelace
amtB, Map StakeAddress (Hash StakePoolKey)
delegB) -> (Map StakeAddress Lovelace
amtA Map StakeAddress Lovelace
-> Map StakeAddress Lovelace -> Map StakeAddress Lovelace
forall a. Semigroup a => a -> a -> a
<> Map StakeAddress Lovelace
amtB, Map StakeAddress (Hash StakePoolKey)
delegA Map StakeAddress (Hash StakePoolKey)
-> Map StakeAddress (Hash StakePoolKey)
-> Map StakeAddress (Hash StakePoolKey)
forall a. Semigroup a => a -> a -> a
<> Map StakeAddress (Hash StakePoolKey)
delegB))
             (Map StakeAddress Lovelace
forall a. Monoid a => a
mempty, Map StakeAddress (Hash StakePoolKey)
forall a. Monoid a => a
mempty)
             [(Map StakeAddress Lovelace, Map StakeAddress (Hash StakePoolKey))]
maps

     decodeObject :: Aeson.Value
                  -> Aeson.Parser (StakeAddress, Maybe Lovelace, Maybe PoolId)
     decodeObject :: Value
-> Parser (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))
decodeObject  = String
-> (Object
    -> Parser
         (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey)))
-> Value
-> Parser (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"DelegationsAndRewards" ((Object
  -> Parser
       (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey)))
 -> Value
 -> Parser
      (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey)))
-> (Object
    -> Parser
         (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey)))
-> Value
-> Parser (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
       StakeAddress
address <- Object
o Object -> Key -> Parser StakeAddress
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"address"
       Maybe (Hash StakePoolKey)
delegation <- Object
o Object -> Key -> Parser (Maybe (Hash StakePoolKey))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"delegation"
       Maybe Lovelace
rewardAccountBalance <- Object
o Object -> Key -> Parser (Maybe Lovelace)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"rewardAccountBalance"
       (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))
-> Parser (StakeAddress, Maybe Lovelace, Maybe (Hash StakePoolKey))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StakeAddress
address, Maybe Lovelace
rewardAccountBalance, Maybe (Hash StakePoolKey)
delegation)

runQueryLeadershipSchedule
  :: AnyConsensusModeParams
  -> NetworkId
  -> GenesisFile -- ^ Shelley genesis
  -> VerificationKeyOrHashOrFile StakePoolKey
  -> SigningKeyFile -- ^ VRF signing key
  -> EpochLeadershipSchedule
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryLeadershipSchedule :: AnyConsensusModeParams
-> NetworkId
-> GenesisFile
-> VerificationKeyOrHashOrFile StakePoolKey
-> SigningKeyFile
-> EpochLeadershipSchedule
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryLeadershipSchedule (AnyConsensusModeParams ConsensusModeParams mode
cModeParams) NetworkId
network
                           (GenesisFile String
genFile) VerificationKeyOrHashOrFile StakePoolKey
coldVerKeyFile (SigningKeyFile String
vrfSkeyFp)
                           EpochLeadershipSchedule
whichSchedule Maybe OutputFile
mJsonOutputFile = do
  SocketPath String
sockPath <- (EnvSocketError -> ShelleyQueryCmdError)
-> ExceptT EnvSocketError IO SocketPath
-> ExceptT ShelleyQueryCmdError IO SocketPath
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr ExceptT EnvSocketError IO SocketPath
readEnvSocketPath
  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
forall mode.
ConsensusModeParams mode
-> NetworkId -> String -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network String
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> ExceptT ShelleyQueryCmdError IO AnyCardanoEra
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo
  ShelleyBasedEra era
sbe <- CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe (CardanoEraStyle era
 -> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era))
-> CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError IO (ShelleyBasedEra era)
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> CardanoEraStyle era
forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era
  let cMode :: ConsensusMode mode
cMode = ConsensusModeParams mode -> ConsensusMode mode
forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams

  Hash StakePoolKey
poolid <- (FileError InputDecodeError -> ShelleyQueryCmdError)
-> ExceptT (FileError InputDecodeError) IO (Hash StakePoolKey)
-> ExceptT ShelleyQueryCmdError IO (Hash StakePoolKey)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT FileError InputDecodeError -> ShelleyQueryCmdError
ShelleyQueryCmdTextReadError
              (ExceptT (FileError InputDecodeError) IO (Hash StakePoolKey)
 -> ExceptT ShelleyQueryCmdError IO (Hash StakePoolKey))
-> (IO (Either (FileError InputDecodeError) (Hash StakePoolKey))
    -> ExceptT (FileError InputDecodeError) IO (Hash StakePoolKey))
-> IO (Either (FileError InputDecodeError) (Hash StakePoolKey))
-> ExceptT ShelleyQueryCmdError IO (Hash StakePoolKey)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO (Either (FileError InputDecodeError) (Hash StakePoolKey))
-> ExceptT (FileError InputDecodeError) IO (Hash StakePoolKey)
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT (IO (Either (FileError InputDecodeError) (Hash StakePoolKey))
 -> ExceptT ShelleyQueryCmdError IO (Hash StakePoolKey))
-> IO (Either (FileError InputDecodeError) (Hash StakePoolKey))
-> ExceptT ShelleyQueryCmdError IO (Hash StakePoolKey)
forall a b. (a -> b) -> a -> b
$ AsType StakePoolKey
-> VerificationKeyOrHashOrFile StakePoolKey
-> IO (Either (FileError InputDecodeError) (Hash StakePoolKey))
forall keyrole.
(Key keyrole, SerialiseAsBech32 (VerificationKey keyrole)) =>
AsType keyrole
-> VerificationKeyOrHashOrFile keyrole
-> IO (Either (FileError InputDecodeError) (Hash keyrole))
readVerificationKeyOrHashOrFile AsType StakePoolKey
AsStakePoolKey VerificationKeyOrHashOrFile StakePoolKey
coldVerKeyFile

  SigningKey VrfKey
vrkSkey <- (FileError TextEnvelopeError -> ShelleyQueryCmdError)
-> ExceptT (FileError TextEnvelopeError) IO (SigningKey VrfKey)
-> ExceptT ShelleyQueryCmdError IO (SigningKey VrfKey)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT FileError TextEnvelopeError -> ShelleyQueryCmdError
ShelleyQueryCmdTextEnvelopeReadError (ExceptT (FileError TextEnvelopeError) IO (SigningKey VrfKey)
 -> ExceptT ShelleyQueryCmdError IO (SigningKey VrfKey))
-> (IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
    -> ExceptT (FileError TextEnvelopeError) IO (SigningKey VrfKey))
-> IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
-> ExceptT ShelleyQueryCmdError IO (SigningKey VrfKey)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
-> ExceptT (FileError TextEnvelopeError) IO (SigningKey VrfKey)
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT
               (IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
 -> ExceptT ShelleyQueryCmdError IO (SigningKey VrfKey))
-> IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
-> ExceptT ShelleyQueryCmdError IO (SigningKey VrfKey)
forall a b. (a -> b) -> a -> b
$ AsType (SigningKey VrfKey)
-> String
-> IO (Either (FileError TextEnvelopeError) (SigningKey VrfKey))
forall a.
HasTextEnvelope a =>
AsType a -> String -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope (AsType VrfKey -> AsType (SigningKey VrfKey)
forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType VrfKey
AsVrfKey) String
vrfSkeyFp
  ShelleyGenesis StandardShelley
shelleyGenesis <- (ShelleyGenesisCmdError -> ShelleyQueryCmdError)
-> ExceptT
     ShelleyGenesisCmdError IO (ShelleyGenesis StandardShelley)
-> ExceptT ShelleyQueryCmdError IO (ShelleyGenesis StandardShelley)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ShelleyGenesisCmdError -> ShelleyQueryCmdError
ShelleyQueryCmdGenesisReadError (ExceptT ShelleyGenesisCmdError IO (ShelleyGenesis StandardShelley)
 -> ExceptT
      ShelleyQueryCmdError IO (ShelleyGenesis StandardShelley))
-> ExceptT
     ShelleyGenesisCmdError IO (ShelleyGenesis StandardShelley)
-> ExceptT ShelleyQueryCmdError IO (ShelleyGenesis StandardShelley)
forall a b. (a -> b) -> a -> b
$
                          IO (Either ShelleyGenesisCmdError (ShelleyGenesis StandardShelley))
-> ExceptT
     ShelleyGenesisCmdError IO (ShelleyGenesis StandardShelley)
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT (IO
   (Either ShelleyGenesisCmdError (ShelleyGenesis StandardShelley))
 -> ExceptT
      ShelleyGenesisCmdError IO (ShelleyGenesis StandardShelley))
-> IO
     (Either ShelleyGenesisCmdError (ShelleyGenesis StandardShelley))
-> ExceptT
     ShelleyGenesisCmdError IO (ShelleyGenesis StandardShelley)
forall a b. (a -> b) -> a -> b
$ String
-> IO
     (Either ShelleyGenesisCmdError (ShelleyGenesis StandardShelley))
readAndDecodeShelleyGenesis String
genFile
  case ConsensusMode mode
cMode of
    ConsensusMode mode
CardanoMode -> do
      EraInMode era mode
eInMode <- CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode
          Maybe (EraInMode era mode)
-> (Maybe (EraInMode era mode)
    -> ExceptT ShelleyQueryCmdError IO (EraInMode era mode))
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
forall a b. a -> (a -> b) -> b
& ShelleyQueryCmdError
-> Maybe (EraInMode era mode)
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe (AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE)

      let pparamsQuery :: QueryInMode mode (Either EraMismatch ProtocolParameters)
pparamsQuery = EraInMode era mode
-> QueryInEra era ProtocolParameters
-> QueryInMode mode (Either EraMismatch ProtocolParameters)
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era ProtocolParameters
 -> QueryInMode mode (Either EraMismatch ProtocolParameters))
-> QueryInEra era ProtocolParameters
-> QueryInMode mode (Either EraMismatch ProtocolParameters)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> QueryInShelleyBasedEra era ProtocolParameters
-> QueryInEra era ProtocolParameters
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe QueryInShelleyBasedEra era ProtocolParameters
forall era. QueryInShelleyBasedEra era ProtocolParameters
QueryProtocolParameters
          ptclStateQuery :: QueryInMode mode (Either EraMismatch (ProtocolState era))
ptclStateQuery = EraInMode era mode
-> QueryInEra era (ProtocolState era)
-> QueryInMode mode (Either EraMismatch (ProtocolState era))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era (ProtocolState era)
 -> QueryInMode
      CardanoMode (Either EraMismatch (ProtocolState era)))
-> (QueryInShelleyBasedEra era (ProtocolState era)
    -> QueryInEra era (ProtocolState era))
-> QueryInShelleyBasedEra era (ProtocolState era)
-> QueryInMode CardanoMode (Either EraMismatch (ProtocolState era))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ShelleyBasedEra era
-> QueryInShelleyBasedEra era (ProtocolState era)
-> QueryInEra era (ProtocolState era)
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe (QueryInShelleyBasedEra era (ProtocolState era)
 -> QueryInMode mode (Either EraMismatch (ProtocolState era)))
-> QueryInShelleyBasedEra era (ProtocolState era)
-> QueryInMode mode (Either EraMismatch (ProtocolState era))
forall a b. (a -> b) -> a -> b
$ QueryInShelleyBasedEra era (ProtocolState era)
forall era. QueryInShelleyBasedEra era (ProtocolState era)
QueryProtocolState
          eraHistoryQuery :: QueryInMode CardanoMode (EraHistory CardanoMode)
eraHistoryQuery = ConsensusModeIsMultiEra CardanoMode
-> QueryInMode CardanoMode (EraHistory CardanoMode)
forall mode.
ConsensusModeIsMultiEra mode -> QueryInMode mode (EraHistory mode)
QueryEraHistory ConsensusModeIsMultiEra CardanoMode
CardanoModeIsMultiEra

      ProtocolParameters
pparams <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch ProtocolParameters)
-> ExceptT ShelleyQueryCmdError IO ProtocolParameters
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery CardanoEra era
era ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo QueryInMode mode (Either EraMismatch ProtocolParameters)
pparamsQuery
      ProtocolState era
ptclState <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch (ProtocolState era))
-> ExceptT ShelleyQueryCmdError IO (ProtocolState era)
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery CardanoEra era
era ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo QueryInMode mode (Either EraMismatch (ProtocolState era))
ptclStateQuery
      EraHistory CardanoMode
eraHistory <- (AcquireFailure -> ShelleyQueryCmdError)
-> ExceptT AcquireFailure IO (EraHistory CardanoMode)
-> ExceptT ShelleyQueryCmdError IO (EraHistory CardanoMode)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT AcquireFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure (ExceptT AcquireFailure IO (EraHistory CardanoMode)
 -> ExceptT ShelleyQueryCmdError IO (EraHistory CardanoMode))
-> (IO (Either AcquireFailure (EraHistory CardanoMode))
    -> ExceptT AcquireFailure IO (EraHistory CardanoMode))
-> IO (Either AcquireFailure (EraHistory CardanoMode))
-> ExceptT ShelleyQueryCmdError IO (EraHistory CardanoMode)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IO (Either AcquireFailure (EraHistory CardanoMode))
-> ExceptT AcquireFailure IO (EraHistory CardanoMode)
forall (m :: * -> *) x a. m (Either x a) -> ExceptT x m a
newExceptT (IO (Either AcquireFailure (EraHistory CardanoMode))
 -> ExceptT ShelleyQueryCmdError IO (EraHistory CardanoMode))
-> IO (Either AcquireFailure (EraHistory CardanoMode))
-> ExceptT ShelleyQueryCmdError IO (EraHistory CardanoMode)
forall a b. (a -> b) -> a -> b
$ LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> QueryInMode mode (EraHistory CardanoMode)
-> IO (Either AcquireFailure (EraHistory CardanoMode))
forall mode result.
LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> QueryInMode mode result
-> IO (Either AcquireFailure result)
queryNodeLocalState LocalNodeConnectInfo mode
localNodeConnInfo Maybe ChainPoint
forall a. Maybe a
Nothing QueryInMode mode (EraHistory CardanoMode)
QueryInMode CardanoMode (EraHistory CardanoMode)
eraHistoryQuery
      let eInfo :: EpochInfo (Either Text)
eInfo = EraHistory CardanoMode -> EpochInfo (Either Text)
toEpochInfo EraHistory CardanoMode
eraHistory

      Set SlotNo
schedule :: Set SlotNo
        <- case EpochLeadershipSchedule
whichSchedule of
             EpochLeadershipSchedule
CurrentEpoch -> do
               let currentEpochStateQuery :: QueryInMode
  mode (Either EraMismatch (SerialisedCurrentEpochState era))
currentEpochStateQuery = EraInMode era mode
-> QueryInEra era (SerialisedCurrentEpochState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedCurrentEpochState era))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era (SerialisedCurrentEpochState era)
 -> QueryInMode
      mode (Either EraMismatch (SerialisedCurrentEpochState era)))
-> QueryInEra era (SerialisedCurrentEpochState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedCurrentEpochState era))
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> QueryInShelleyBasedEra era (SerialisedCurrentEpochState era)
-> QueryInEra era (SerialisedCurrentEpochState era)
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe QueryInShelleyBasedEra era (SerialisedCurrentEpochState era)
forall era.
QueryInShelleyBasedEra era (SerialisedCurrentEpochState era)
QueryCurrentEpochState
                   currentEpochQuery :: QueryInMode mode (Either EraMismatch EpochNo)
currentEpochQuery = EraInMode era mode
-> QueryInEra era EpochNo
-> QueryInMode mode (Either EraMismatch EpochNo)
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era EpochNo
 -> QueryInMode mode (Either EraMismatch EpochNo))
-> QueryInEra era EpochNo
-> QueryInMode mode (Either EraMismatch EpochNo)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> QueryInShelleyBasedEra era EpochNo -> QueryInEra era EpochNo
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe QueryInShelleyBasedEra era EpochNo
forall era. QueryInShelleyBasedEra era EpochNo
QueryEpoch
               SerialisedCurrentEpochState era
serCurrentEpochState <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode
     mode (Either EraMismatch (SerialisedCurrentEpochState era))
-> ExceptT
     ShelleyQueryCmdError IO (SerialisedCurrentEpochState era)
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery CardanoEra era
era ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo QueryInMode
  mode (Either EraMismatch (SerialisedCurrentEpochState era))
currentEpochStateQuery
               EpochNo
curentEpoch <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch EpochNo)
-> ExceptT ShelleyQueryCmdError IO EpochNo
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery CardanoEra era
era ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo QueryInMode mode (Either EraMismatch EpochNo)
currentEpochQuery
               (LeadershipError -> ShelleyQueryCmdError)
-> ExceptT LeadershipError IO (Set SlotNo)
-> ExceptT ShelleyQueryCmdError IO (Set SlotNo)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT LeadershipError -> ShelleyQueryCmdError
ShelleyQueryCmdLeaderShipError (ExceptT LeadershipError IO (Set SlotNo)
 -> ExceptT ShelleyQueryCmdError IO (Set SlotNo))
-> ExceptT LeadershipError IO (Set SlotNo)
-> ExceptT ShelleyQueryCmdError IO (Set SlotNo)
forall a b. (a -> b) -> a -> b
$ Either LeadershipError (Set SlotNo)
-> ExceptT LeadershipError IO (Set SlotNo)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither
                (Either LeadershipError (Set SlotNo)
 -> ExceptT LeadershipError IO (Set SlotNo))
-> Either LeadershipError (Set SlotNo)
-> ExceptT LeadershipError IO (Set SlotNo)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> ((ShelleyLedgerEra era ~ ShelleyLedgerEra era,
     Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
     PraosProtocolSupportsNode (ConsensusProtocol era),
     FromCBOR (ChainDepState (ConsensusProtocol era)),
     Era (ShelleyLedgerEra era),
     HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
     Signable (VRF (Crypto (ShelleyLedgerEra era))) Seed,
     Share (TxOut (ShelleyLedgerEra era))
     ~ Interns (Credential 'Staking StandardCrypto),
     ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
     ~ Blake2b_224) =>
    Either LeadershipError (Set SlotNo))
-> Either LeadershipError (Set SlotNo)
forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((ShelleyLedgerEra era ~ ledgerera,
     Crypto ledgerera ~ StandardCrypto,
     PraosProtocolSupportsNode (ConsensusProtocol era),
     FromCBOR (ChainDepState (ConsensusProtocol era)), Era ledgerera,
     HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
     Signable (VRF (Crypto ledgerera)) Seed,
     Share (TxOut (ShelleyLedgerEra era))
     ~ Interns (Credential 'Staking StandardCrypto),
     ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
     ~ Blake2b_224) =>
    a)
-> a
eligibleLeaderSlotsConstaints ShelleyBasedEra era
sbe
                (((ShelleyLedgerEra era ~ ShelleyLedgerEra era,
   Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
   PraosProtocolSupportsNode (ConsensusProtocol era),
   FromCBOR (ChainDepState (ConsensusProtocol era)),
   Era (ShelleyLedgerEra era),
   HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
   Signable (VRF (Crypto (ShelleyLedgerEra era))) Seed,
   Share (TxOut (ShelleyLedgerEra era))
   ~ Interns (Credential 'Staking StandardCrypto),
   ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
   ~ Blake2b_224) =>
  Either LeadershipError (Set SlotNo))
 -> Either LeadershipError (Set SlotNo))
-> ((ShelleyLedgerEra era ~ ShelleyLedgerEra era,
     Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
     PraosProtocolSupportsNode (ConsensusProtocol era),
     FromCBOR (ChainDepState (ConsensusProtocol era)),
     Era (ShelleyLedgerEra era),
     HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
     Signable (VRF (Crypto (ShelleyLedgerEra era))) Seed,
     Share (TxOut (ShelleyLedgerEra era))
     ~ Interns (Credential 'Staking StandardCrypto),
     ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
     ~ Blake2b_224) =>
    Either LeadershipError (Set SlotNo))
-> Either LeadershipError (Set SlotNo)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> ShelleyGenesis StandardShelley
-> EpochInfo (Either Text)
-> ProtocolParameters
-> ProtocolState era
-> Hash StakePoolKey
-> SigningKey VrfKey
-> SerialisedCurrentEpochState era
-> EpochNo
-> Either LeadershipError (Set SlotNo)
forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera, Era ledgerera,
 PraosProtocolSupportsNode (ConsensusProtocol era),
 HasField "_d" (PParams ledgerera) UnitInterval,
 Share (TxOut (ShelleyLedgerEra era))
 ~ Interns (Credential 'Staking (Crypto (ShelleyLedgerEra era))),
 FromCBOR (ChainDepState (ConsensusProtocol era))) =>
ShelleyBasedEra era
-> ShelleyGenesis StandardShelley
-> EpochInfo (Either Text)
-> ProtocolParameters
-> ProtocolState era
-> Hash StakePoolKey
-> SigningKey VrfKey
-> SerialisedCurrentEpochState era
-> EpochNo
-> Either LeadershipError (Set SlotNo)
currentEpochEligibleLeadershipSlots
                    ShelleyBasedEra era
sbe
                    ShelleyGenesis StandardShelley
shelleyGenesis
                    EpochInfo (Either Text)
eInfo
                    ProtocolParameters
pparams
                    ProtocolState era
ptclState
                    Hash StakePoolKey
poolid
                    SigningKey VrfKey
vrkSkey
                    SerialisedCurrentEpochState era
serCurrentEpochState
                    EpochNo
curentEpoch

             EpochLeadershipSchedule
NextEpoch -> do
               let currentEpochStateQuery :: QueryInMode
  mode (Either EraMismatch (SerialisedCurrentEpochState era))
currentEpochStateQuery = EraInMode era mode
-> QueryInEra era (SerialisedCurrentEpochState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedCurrentEpochState era))
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era (SerialisedCurrentEpochState era)
 -> QueryInMode
      mode (Either EraMismatch (SerialisedCurrentEpochState era)))
-> QueryInEra era (SerialisedCurrentEpochState era)
-> QueryInMode
     mode (Either EraMismatch (SerialisedCurrentEpochState era))
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> QueryInShelleyBasedEra era (SerialisedCurrentEpochState era)
-> QueryInEra era (SerialisedCurrentEpochState era)
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe QueryInShelleyBasedEra era (SerialisedCurrentEpochState era)
forall era.
QueryInShelleyBasedEra era (SerialisedCurrentEpochState era)
QueryCurrentEpochState
                   currentEpochQuery :: QueryInMode mode (Either EraMismatch EpochNo)
currentEpochQuery = EraInMode era mode
-> QueryInEra era EpochNo
-> QueryInMode mode (Either EraMismatch EpochNo)
forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode (QueryInEra era EpochNo
 -> QueryInMode mode (Either EraMismatch EpochNo))
-> QueryInEra era EpochNo
-> QueryInMode mode (Either EraMismatch EpochNo)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> QueryInShelleyBasedEra era EpochNo -> QueryInEra era EpochNo
forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe QueryInShelleyBasedEra era EpochNo
forall era. QueryInShelleyBasedEra era EpochNo
QueryEpoch
               ChainTip
tip <- IO ChainTip -> ExceptT ShelleyQueryCmdError IO ChainTip
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ChainTip -> ExceptT ShelleyQueryCmdError IO ChainTip)
-> IO ChainTip -> ExceptT ShelleyQueryCmdError IO ChainTip
forall a b. (a -> b) -> a -> b
$ LocalNodeConnectInfo mode -> IO ChainTip
forall mode. LocalNodeConnectInfo mode -> IO ChainTip
getLocalChainTip LocalNodeConnectInfo mode
localNodeConnInfo

               EpochNo
curentEpoch <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch EpochNo)
-> ExceptT ShelleyQueryCmdError IO EpochNo
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery CardanoEra era
era ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo QueryInMode mode (Either EraMismatch EpochNo)
currentEpochQuery
               SerialisedCurrentEpochState era
serCurrentEpochState <- CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode
     mode (Either EraMismatch (SerialisedCurrentEpochState era))
-> ExceptT
     ShelleyQueryCmdError IO (SerialisedCurrentEpochState era)
forall result era mode.
CardanoEra era
-> ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> QueryInMode mode (Either EraMismatch result)
-> ExceptT ShelleyQueryCmdError IO result
executeQuery CardanoEra era
era ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo QueryInMode
  mode (Either EraMismatch (SerialisedCurrentEpochState era))
currentEpochStateQuery

               (LeadershipError -> ShelleyQueryCmdError)
-> ExceptT LeadershipError IO (Set SlotNo)
-> ExceptT ShelleyQueryCmdError IO (Set SlotNo)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT LeadershipError -> ShelleyQueryCmdError
ShelleyQueryCmdLeaderShipError (ExceptT LeadershipError IO (Set SlotNo)
 -> ExceptT ShelleyQueryCmdError IO (Set SlotNo))
-> ExceptT LeadershipError IO (Set SlotNo)
-> ExceptT ShelleyQueryCmdError IO (Set SlotNo)
forall a b. (a -> b) -> a -> b
$ Either LeadershipError (Set SlotNo)
-> ExceptT LeadershipError IO (Set SlotNo)
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither
                (Either LeadershipError (Set SlotNo)
 -> ExceptT LeadershipError IO (Set SlotNo))
-> Either LeadershipError (Set SlotNo)
-> ExceptT LeadershipError IO (Set SlotNo)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> ((ShelleyLedgerEra era ~ ShelleyLedgerEra era,
     Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
     PraosProtocolSupportsNode (ConsensusProtocol era),
     FromCBOR (ChainDepState (ConsensusProtocol era)),
     Era (ShelleyLedgerEra era),
     HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
     Signable (VRF (Crypto (ShelleyLedgerEra era))) Seed,
     Share (TxOut (ShelleyLedgerEra era))
     ~ Interns (Credential 'Staking StandardCrypto),
     ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
     ~ Blake2b_224) =>
    Either LeadershipError (Set SlotNo))
-> Either LeadershipError (Set SlotNo)
forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((ShelleyLedgerEra era ~ ledgerera,
     Crypto ledgerera ~ StandardCrypto,
     PraosProtocolSupportsNode (ConsensusProtocol era),
     FromCBOR (ChainDepState (ConsensusProtocol era)), Era ledgerera,
     HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
     Signable (VRF (Crypto ledgerera)) Seed,
     Share (TxOut (ShelleyLedgerEra era))
     ~ Interns (Credential 'Staking StandardCrypto),
     ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
     ~ Blake2b_224) =>
    a)
-> a
eligibleLeaderSlotsConstaints ShelleyBasedEra era
sbe
                (((ShelleyLedgerEra era ~ ShelleyLedgerEra era,
   Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
   PraosProtocolSupportsNode (ConsensusProtocol era),
   FromCBOR (ChainDepState (ConsensusProtocol era)),
   Era (ShelleyLedgerEra era),
   HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
   Signable (VRF (Crypto (ShelleyLedgerEra era))) Seed,
   Share (TxOut (ShelleyLedgerEra era))
   ~ Interns (Credential 'Staking StandardCrypto),
   ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
   ~ Blake2b_224) =>
  Either LeadershipError (Set SlotNo))
 -> Either LeadershipError (Set SlotNo))
-> ((ShelleyLedgerEra era ~ ShelleyLedgerEra era,
     Crypto (ShelleyLedgerEra era) ~ StandardCrypto,
     PraosProtocolSupportsNode (ConsensusProtocol era),
     FromCBOR (ChainDepState (ConsensusProtocol era)),
     Era (ShelleyLedgerEra era),
     HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
     Signable (VRF (Crypto (ShelleyLedgerEra era))) Seed,
     Share (TxOut (ShelleyLedgerEra era))
     ~ Interns (Credential 'Staking StandardCrypto),
     ADDRHASH (PraosProtocolSupportsNodeCrypto (ConsensusProtocol era))
     ~ Blake2b_224) =>
    Either LeadershipError (Set SlotNo))
-> Either LeadershipError (Set SlotNo)
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> ShelleyGenesis StandardShelley
-> SerialisedCurrentEpochState era
-> ProtocolState era
-> Hash StakePoolKey
-> SigningKey VrfKey
-> ProtocolParameters
-> EpochInfo (Either Text)
-> (ChainTip, EpochNo)
-> Either LeadershipError (Set SlotNo)
forall era.
(HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
 Era (ShelleyLedgerEra era),
 Share (TxOut (ShelleyLedgerEra era))
 ~ Interns (Credential 'Staking (Crypto (ShelleyLedgerEra era))),
 FromCBOR (ChainDepState (ConsensusProtocol era)),
 PraosProtocolSupportsNode (ConsensusProtocol era)) =>
ShelleyBasedEra era
-> ShelleyGenesis StandardShelley
-> SerialisedCurrentEpochState era
-> ProtocolState era
-> Hash StakePoolKey
-> SigningKey VrfKey
-> ProtocolParameters
-> EpochInfo (Either Text)
-> (ChainTip, EpochNo)
-> Either LeadershipError (Set SlotNo)
nextEpochEligibleLeadershipSlots ShelleyBasedEra era
sbe ShelleyGenesis StandardShelley
shelleyGenesis
                    SerialisedCurrentEpochState era
serCurrentEpochState ProtocolState era
ptclState Hash StakePoolKey
poolid SigningKey VrfKey
vrkSkey ProtocolParameters
pparams
                    EpochInfo (Either Text)
eInfo (ChainTip
tip, EpochNo
curentEpoch)

      case Maybe OutputFile
mJsonOutputFile of
        Maybe OutputFile
Nothing -> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ Set SlotNo -> EpochInfo (Either Text) -> SystemStart -> IO ()
printLeadershipScheduleAsText Set SlotNo
schedule EpochInfo (Either Text)
eInfo (UTCTime -> SystemStart
SystemStart (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis StandardShelley -> UTCTime
forall era. ShelleyGenesis era -> UTCTime
sgSystemStart ShelleyGenesis StandardShelley
shelleyGenesis)
        Just (OutputFile String
jsonOutputFile) ->
          IO () -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT ShelleyQueryCmdError IO ())
-> IO () -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
LBS.writeFile String
jsonOutputFile (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
            Set SlotNo -> EpochInfo (Either Text) -> SystemStart -> ByteString
printLeadershipScheduleAsJson Set SlotNo
schedule EpochInfo (Either Text)
eInfo (UTCTime -> SystemStart
SystemStart (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis StandardShelley -> UTCTime
forall era. ShelleyGenesis era -> UTCTime
sgSystemStart ShelleyGenesis StandardShelley
shelleyGenesis)
    ConsensusMode mode
mode -> ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ()
forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (ShelleyQueryCmdError -> ExceptT ShelleyQueryCmdError IO ())
-> (AnyConsensusMode -> ShelleyQueryCmdError)
-> AnyConsensusMode
-> ExceptT ShelleyQueryCmdError IO ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. AnyConsensusMode -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedMode (AnyConsensusMode -> ExceptT ShelleyQueryCmdError IO ())
-> AnyConsensusMode -> ExceptT ShelleyQueryCmdError IO ()
forall a b. (a -> b) -> a -> b
$ ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
mode
 where
  printLeadershipScheduleAsText
    :: Set SlotNo
    -> EpochInfo (Either Text)
    -> SystemStart
    -> IO ()
  printLeadershipScheduleAsText :: Set SlotNo -> EpochInfo (Either Text) -> SystemStart -> IO ()
printLeadershipScheduleAsText Set SlotNo
leadershipSlots EpochInfo (Either Text)
eInfo SystemStart
sStart = do
    Text -> IO ()
Text.putStrLn Text
title
    String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Text -> Int
Text.length Text
title Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Char
'-'
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [ String -> IO ()
forall a (m :: * -> *). (Print a, MonadIO m) => a -> m ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> EpochInfo (Either Text) -> SystemStart -> String
showLeadershipSlot SlotNo
slot EpochInfo (Either Text)
eInfo SystemStart
sStart
      | SlotNo
slot <- Set SlotNo -> [SlotNo]
forall a. Set a -> [a]
Set.toList Set SlotNo
leadershipSlots ]
   where
     title :: Text
     title :: Text
title =
       Text
"     SlotNo                          UTC Time              "

     showLeadershipSlot
       :: SlotNo
       -> EpochInfo (Either Text)
       -> SystemStart
       -> String
     showLeadershipSlot :: SlotNo -> EpochInfo (Either Text) -> SystemStart -> String
showLeadershipSlot lSlot :: SlotNo
lSlot@(SlotNo Word64
sn) EpochInfo (Either Text)
eInfo' SystemStart
sStart' =
       case EpochInfo (Either Text)
-> SystemStart -> SlotNo -> Either Text UTCTime
forall (m :: * -> *).
(HasCallStack, Monad m) =>
EpochInfo m -> SystemStart -> SlotNo -> m UTCTime
epochInfoSlotToUTCTime EpochInfo (Either Text)
eInfo' SystemStart
sStart' SlotNo
lSlot of
         Right UTCTime
slotTime ->
          [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
           [ String
"     "
           , Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Word64
sn
           , String
"                   "
           , UTCTime -> String
forall a b. (Show a, ConvertText String b) => a -> b
show UTCTime
slotTime
           ]
         Left Text
err ->
          [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
           [ String
"     "
           , Word64 -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Word64
sn
           , String
"                   "
           , Text -> String
Text.unpack Text
err
           ]
  printLeadershipScheduleAsJson
    :: Set SlotNo
    -> EpochInfo (Either Text)
    -> SystemStart
    -> LBS.ByteString
  printLeadershipScheduleAsJson :: Set SlotNo -> EpochInfo (Either Text) -> SystemStart -> ByteString
printLeadershipScheduleAsJson Set SlotNo
leadershipSlots EpochInfo (Either Text)
eInfo SystemStart
sStart =
    [Value] -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty ([Value] -> ByteString) -> [Value] -> ByteString
forall a b. (a -> b) -> a -> b
$ SlotNo -> Value
showLeadershipSlot (SlotNo -> Value) -> [SlotNo] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SlotNo] -> [SlotNo]
forall a. Ord a => [a] -> [a]
sort (Set SlotNo -> [SlotNo]
forall a. Set a -> [a]
Set.toList Set SlotNo
leadershipSlots)
    where
      showLeadershipSlot :: SlotNo -> Aeson.Value
      showLeadershipSlot :: SlotNo -> Value
showLeadershipSlot lSlot :: SlotNo
lSlot@(SlotNo Word64
sn) =
        case EpochInfo (Either Text)
-> SystemStart -> SlotNo -> Either Text UTCTime
forall (m :: * -> *).
(HasCallStack, Monad m) =>
EpochInfo m -> SystemStart -> SlotNo -> m UTCTime
epochInfoSlotToUTCTime EpochInfo (Either Text)
eInfo SystemStart
sStart SlotNo
lSlot of
          Right UTCTime
slotTime ->
            [Pair] -> Value
Aeson.object
              [ Key
"slotNumber" Key -> Word64 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
Aeson..= Word64
sn
              , Key
"slotTime" Key -> UTCTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
Aeson..= UTCTime
slotTime
              ]
          Left Text
err ->
            [Pair] -> Value
Aeson.object
              [ Key
"slotNumber" Key -> Word64 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
Aeson..= Word64
sn
              , Key
"error" Key -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
Aeson..= Text -> String
Text.unpack Text
err
              ]


-- Helpers

calcEraInMode
  :: CardanoEra era
  -> ConsensusMode mode
  -> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
calcEraInMode :: CardanoEra era
-> ConsensusMode mode
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
calcEraInMode CardanoEra era
era ConsensusMode mode
mode=
  ShelleyQueryCmdError
-> Maybe (EraInMode era mode)
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe (AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (ConsensusMode mode -> AnyConsensusMode
forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
mode) (CardanoEra era -> AnyCardanoEra
forall era. CardanoEra era -> AnyCardanoEra
anyCardanoEra CardanoEra era
era))
                   (Maybe (EraInMode era mode)
 -> ExceptT ShelleyQueryCmdError IO (EraInMode era mode))
-> Maybe (EraInMode era mode)
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
forall a b. (a -> b) -> a -> b
$ CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
mode

determineEra
  :: ConsensusModeParams