{-# 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
  , toEpochInfo
  , determineEra
  , mergeDelegsAndRewards
  , percentage
  , executeQuery
  ) where

import           Cardano.Api
import qualified Cardano.Api as Api
import           Cardano.Api.Byron
import           Cardano.Api.Orphans ()
import           Cardano.Api.Shelley

import           Control.Monad.Trans.Except (ExceptT (..), except, runExcept, runExceptT)
import           Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither,
                   hoistMaybe, left, onLeft, onNothing)
import           Data.Aeson as Aeson
import           Data.Aeson.Encode.Pretty (encodePretty)
import           Data.Aeson.Types as Aeson
import qualified Data.ByteString.Lazy.Char8 as LBS
import           Data.Coerce (coerce)
import           Data.List (nub)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import           Data.Sharing (Interns, Share)
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           Data.Text.Lazy.Builder (toLazyText)
import           Data.Time.Clock
import qualified Data.Vector as Vector
import           Formatting.Buildable (build)
import           Numeric (showEFloat)
import           Prettyprinter
import qualified System.IO as IO
import           Text.Printf (printf)

import           Cardano.Binary (DecoderError)
import           Cardano.CLI.Helpers (HelpersError (..), hushM, pPrintCBOR, renderHelpersError)
import           Cardano.CLI.Pretty
import           Cardano.CLI.Shelley.Commands
import           Cardano.CLI.Shelley.Key (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 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.SafeHash (HashAnnotated)
import           Cardano.Ledger.Shelley.LedgerState (PState (_fPParams, _pParams, _retiring))
import qualified Cardano.Ledger.Shelley.LedgerState as SL
import qualified Cardano.Ledger.Shelley.PParams as Shelley
import           Cardano.Ledger.Shelley.Scripts ()
import           Cardano.Slotting.EpochInfo (EpochInfo (..), epochInfoSlotToUTCTime, hoistEpochInfo)

import           Ouroboros.Consensus.BlockchainTime.WallClock.Types (RelativeTime (..),
                   toRelativeTime)
import           Ouroboros.Consensus.Cardano.Block as Consensus (EraMismatch (..))
import           Ouroboros.Consensus.Protocol.TPraos (StandardCrypto)
import           Ouroboros.Network.Block (Serialised (..))

import qualified Ouroboros.Consensus.HardFork.History as Consensus
import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry
import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus
import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus
import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery

import           Control.Monad (forM, forM_, join)
import           Control.Monad.IO.Class (MonadIO)
import           Control.Monad.IO.Unlift (MonadIO (..))
import           Control.Monad.Trans.Class
import           Data.Bifunctor (Bifunctor (..))
import           Data.Function ((&))
import           Data.Functor ((<&>))
import qualified Data.List as List
import           Data.Map.Strict (Map)
import           Data.Proxy (Proxy (..))
import           Data.Set (Set)
import           Data.Text (Text)
import           Data.Text.Lazy (toStrict)
import           GHC.Records (HasField)

{- HLINT ignore "Move brackets to avoid $" -}
{- HLINT ignore "Redundant flip" -}

data ShelleyQueryCmdError
  = ShelleyQueryCmdEnvVarSocketErr !EnvSocketError
  | ShelleyQueryCmdLocalStateQueryError !ShelleyQueryCmdLocalStateQueryError
  | ShelleyQueryCmdWriteFileError !(FileError ())
  | ShelleyQueryCmdHelpersError !HelpersError
  | ShelleyQueryCmdAcquireFailure !AcquiringFailure
  | 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.
  | ShelleyQueryCmdPoolStateDecodeError DecoderError
  | ShelleyQueryCmdStakeSnapshotDecodeError DecoderError
  | ShelleyQueryCmdUnsupportedNtcVersion !UnsupportedNtcVersionError

  deriving Int -> ShelleyQueryCmdError -> ShowS
[ShelleyQueryCmdError] -> ShowS
ShelleyQueryCmdError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ShelleyQueryCmdError] -> ShowS
$cshowList :: [ShelleyQueryCmdError] -> ShowS
show :: ShelleyQueryCmdError -> [Char]
$cshow :: ShelleyQueryCmdError -> [Char]
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 -> [Char] -> Text
Text.pack (forall e. Error e => e -> [Char]
displayError FileError ()
fileErr)
    ShelleyQueryCmdHelpersError HelpersError
helpersErr -> HelpersError -> Text
renderHelpersError HelpersError
helpersErr
    ShelleyQueryCmdAcquireFailure AcquiringFailure
acquireFail -> [Char] -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show AcquiringFailure
acquireFail
    ShelleyQueryCmdError
ShelleyQueryCmdByronEra -> Text
"This query cannot be used for the Byron era"
    ShelleyQueryCmdPoolIdError PoolId
poolId -> Text
"The pool id does not exist: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow PoolId
poolId
    ShelleyQueryCmdEraConsensusModeMismatch (AnyConsensusMode ConsensusMode mode
cMode) (AnyCardanoEra CardanoEra era
era) ->
      Text
"Consensus mode and era mismatch. Consensus mode: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow ConsensusMode mode
cMode forall a. Semigroup a => a -> a -> a
<>
      Text
" Era: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow CardanoEra era
era
    ShelleyQueryCmdEraMismatch (EraMismatch Text
ledgerEra Text
queryEra) ->
      Text
"\nAn error mismatch occurred." forall a. Semigroup a => a -> a -> a
<> Text
"\nSpecified query era: " forall a. Semigroup a => a -> a -> a
<> Text
queryEra forall a. Semigroup a => a -> a -> a
<>
      Text
"\nCurrent ledger era: " forall a. Semigroup a => a -> a -> a
<> Text
ledgerEra
    ShelleyQueryCmdUnsupportedMode AnyConsensusMode
mode -> Text
"Unsupported mode: " forall a. Semigroup a => a -> a -> a
<> AnyConsensusMode -> Text
renderMode AnyConsensusMode
mode
    ShelleyQueryCmdPastHorizon PastHorizonException
e -> Text
"Past horizon: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow PastHorizonException
e
    ShelleyQueryCmdError
ShelleyQueryCmdSystemStartUnavailable -> Text
"System start unavailable"
    ShelleyQueryCmdGenesisReadError ShelleyGenesisCmdError
err' -> [Char] -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall e. Error e => e -> [Char]
displayError ShelleyGenesisCmdError
err'
    ShelleyQueryCmdLeaderShipError LeadershipError
e -> [Char] -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall e. Error e => e -> [Char]
displayError LeadershipError
e
    ShelleyQueryCmdTextEnvelopeReadError FileError TextEnvelopeError
e -> [Char] -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall e. Error e => e -> [Char]
displayError FileError TextEnvelopeError
e
    ShelleyQueryCmdSlotToUtcError Text
e -> Text
"Failed to convert slot to UTC time: " forall a. Semigroup a => a -> a -> a
<> Text
e
    ShelleyQueryCmdTextReadError FileError InputDecodeError
e -> [Char] -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall e. Error e => e -> [Char]
displayError FileError InputDecodeError
e
    ShelleyQueryCmdColdKeyReadFileError FileError InputDecodeError
e -> [Char] -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall e. Error e => e -> [Char]
displayError FileError InputDecodeError
e
    ShelleyQueryCmdOpCertCounterReadError FileError TextEnvelopeError
e -> [Char] -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall e. Error e => e -> [Char]
displayError FileError TextEnvelopeError
e
    ShelleyQueryCmdProtocolStateDecodeFailure (ByteString
_, DecoderError
decErr) ->
      Text
"Failed to decode the protocol state: " forall a. Semigroup a => a -> a -> a
<> Text -> Text
toStrict (Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ forall p. Buildable p => p -> Builder
build DecoderError
decErr)
    ShelleyQueryCmdNodeUnknownStakePool [Char]
nodeOpCert ->
      [Char] -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ [Char]
"The stake pool associated with: " forall a. Semigroup a => a -> a -> a
<> [Char]
nodeOpCert forall a. Semigroup a => a -> a -> a
<> [Char]
" was not found. Ensure the correct KES key has been " forall a. Semigroup a => a -> a -> a
<>
                  [Char]
"specified and that the stake pool is registered. If you have submitted a stake pool registration certificate " forall a. Semigroup a => a -> a -> a
<>
                  [Char]
"in the current epoch, you must wait until the following epoch for the registration to take place."
    ShelleyQueryCmdPoolStateDecodeError DecoderError
decoderError ->
      Text
"Failed to decode PoolState.  Error: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. Show a => a -> [Char]
show DecoderError
decoderError)
    ShelleyQueryCmdStakeSnapshotDecodeError DecoderError
decoderError ->
      Text
"Failed to decode StakeSnapshot.  Error: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. Show a => a -> [Char]
show DecoderError
decoderError)
    ShelleyQueryCmdUnsupportedNtcVersion (UnsupportedNtcVersionError MinNodeToClientVersion
minNtcVersion MinNodeToClientVersion
ntcVersion) ->
      Text
"Unsupported feature for the node-to-client protocol version.\n" forall a. Semigroup a => a -> a -> a
<>
      Text
"This query requires at least " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow MinNodeToClientVersion
minNtcVersion forall a. Semigroup a => a -> a -> a
<> Text
" but the node negotiated " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow MinNodeToClientVersion
ntcVersion forall a. Semigroup a => a -> a -> a
<> Text
".\n" forall a. Semigroup a => a -> a -> a
<>
      Text
"Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)."

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 AllOrOnly [PoolId]
allOrOnlyPoolIds Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> NetworkId
-> AllOrOnly [PoolId]
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeSnapshot AnyConsensusModeParams
consensusModeParams NetworkId
network AllOrOnly [PoolId]
allOrOnlyPoolIds Maybe OutputFile
mOutFile
    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 [Char]
nodeOpCert Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> NetworkId
-> [Char]
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryKesPeriodInfo AnyConsensusModeParams
consensusModeParams NetworkId
network [Char]
nodeOpCert Maybe OutputFile
mOutFile
    QueryPoolState' AnyConsensusModeParams
consensusModeParams NetworkId
network [PoolId]
poolid ->
      AnyConsensusModeParams
-> NetworkId -> [PoolId] -> ExceptT ShelleyQueryCmdError IO ()
runQueryPoolState AnyConsensusModeParams
consensusModeParams NetworkId
network [PoolId]
poolid
    QueryTxMempool AnyConsensusModeParams
consensusModeParams NetworkId
network TxMempoolQuery
op Maybe OutputFile
mOutFile ->
      AnyConsensusModeParams
-> NetworkId
-> TxMempoolQuery
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryTxMempool AnyConsensusModeParams
consensusModeParams NetworkId
network TxMempoolQuery
op 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 [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

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

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

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

        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr
     block
     point
     (QueryInMode mode)
     r
     IO
     (Either UnsupportedNtcVersionError a)
queryExpr forall a b. (a -> b) -> a -> b
$ forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall a b. (a -> b) -> a -> b
$ forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall era. QueryInShelleyBasedEra era ProtocolParameters
QueryProtocolParameters)
          forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnsupportedNtcVersionError -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedNtcVersion)
          forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraMismatch -> ShelleyQueryCmdError
ShelleyQueryCmdEraMismatch)

  Maybe OutputFile
-> ProtocolParameters -> ExceptT ShelleyQueryCmdError IO ()
writeProtocolParameters Maybe OutputFile
mOutFile forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure Either
  AcquiringFailure (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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
LBS.putStrLn (forall a. ToJSON a => a -> ByteString
encodePretty ProtocolParameters
pparams)
      Just (OutputFile [Char]
fpath) ->
        forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. [Char] -> IOException -> FileError e
FileIOError [Char]
fpath) forall a b. (a -> b) -> a -> b
$
          [Char] -> ByteString -> IO ()
LBS.writeFile [Char]
fpath (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 = [Char] -> Text
Text.pack (forall r. PrintfType r => [Char] -> r
printf [Char]
"%.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 forall a. Num a => a -> a -> a
+ Integer
1
        sb :: Integer
sb = RelativeTime -> Integer
relativeTimeSeconds RelativeTime
b 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 = forall a. Ord a => a -> a -> a
min (Integer
sa 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 = forall a. a -> a
id @Double (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ua forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral  Integer
ub) forall a. Num a => a -> a -> a
* Double
100.0

relativeTimeSeconds :: RelativeTime -> Integer
relativeTimeSeconds :: RelativeTime -> Integer
relativeTimeSeconds (RelativeTime NominalDiffTime
dt) = 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 :: forall (m :: * -> *) mode.
MonadIO m =>
LocalNodeConnectInfo mode -> m ChainTip
queryChainTipViaChainSync LocalNodeConnectInfo mode
localNodeConnInfo = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
T.hPutStrLn Handle
IO.stderr forall a b. (a -> b) -> a -> b
$
    Text
"Warning: Local header state query unavailable. Falling back to chain sync query"
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

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

      Either AcquiringFailure (QueryTipLocalState Any)
eLocalState <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$
        forall mode a.
LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> LocalStateQueryExpr
     (BlockInMode mode) ChainPoint (QueryInMode mode) () IO a
-> IO (Either AcquiringFailure a)
executeLocalStateQueryExpr LocalNodeConnectInfo mode
localNodeConnInfo forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
          AnyCardanoEra
era <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr
     block
     point
     (QueryInMode mode)
     r
     IO
     (Either UnsupportedNtcVersionError a)
queryExpr (forall mode.
ConsensusModeIsMultiEra mode -> QueryInMode mode AnyCardanoEra
QueryCurrentEra ConsensusModeIsMultiEra CardanoMode
CardanoModeIsMultiEra)) forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnsupportedNtcVersionError -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedNtcVersion)
          EraHistory CardanoMode
eraHistory <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr
     block
     point
     (QueryInMode mode)
     r
     IO
     (Either UnsupportedNtcVersionError a)
queryExpr (forall mode.
ConsensusModeIsMultiEra mode -> QueryInMode mode (EraHistory mode)
QueryEraHistory ConsensusModeIsMultiEra CardanoMode
CardanoModeIsMultiEra)) forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnsupportedNtcVersionError -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedNtcVersion)
          Maybe (WithOrigin BlockNo)
mChainBlockNo <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr
     block
     point
     (QueryInMode mode)
     r
     IO
     (Either UnsupportedNtcVersionError a)
queryExpr  forall mode. QueryInMode mode (WithOrigin BlockNo)
QueryChainBlockNo) forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnsupportedNtcVersionError -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedNtcVersion) forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just
          Maybe ChainPoint
mChainPoint <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr
     block
     point
     (QueryInMode mode)
     r
     IO
     (Either UnsupportedNtcVersionError a)
queryExpr (forall mode. ConsensusMode mode -> QueryInMode mode ChainPoint
QueryChainPoint ConsensusMode CardanoMode
CardanoMode)) forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnsupportedNtcVersionError -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedNtcVersion) forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just
          Maybe SystemStart
mSystemStart <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr
     block
     point
     (QueryInMode mode)
     r
     IO
     (Either UnsupportedNtcVersionError a)
queryExpr  forall mode. QueryInMode mode SystemStart
QuerySystemStart) forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnsupportedNtcVersionError -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedNtcVersion) forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just

          forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (WithOrigin BlockNo)
mChainBlockNo forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ChainPoint
mChainPoint
            }

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

      ChainTip
chainTip <- forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (QueryTipLocalState Any)
mLocalState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall mode. QueryTipLocalState mode -> Maybe ChainTip
O.mChainTip)
        -- 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.
        forall a b. a -> (a -> b) -> b
& forall x (m :: * -> *) a.
Monad m =>
ExceptT x m a -> ExceptT x m (Maybe a) -> ExceptT x m a
onNothing (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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe (QueryTipLocalState Any)
mLocalState forall a b. (a -> b) -> a -> b
$ \QueryTipLocalState Any
localState -> do
        case forall mode.
SlotNo
-> EraHistory mode
-> Either
     PastHorizonException (EpochNo, SlotsInEpoch, SlotsToEpochEnd)
slotToEpoch SlotNo
tipSlotNo (forall mode. QueryTipLocalState mode -> EraHistory CardanoMode
O.eraHistory QueryTipLocalState Any
localState) of
          Left PastHorizonException
e -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
T.hPutStrLn Handle
IO.stderr forall a b. (a -> b) -> a -> b
$
              Text
"Warning: Epoch unavailable: " forall a. Semigroup a => a -> a -> a
<> ShelleyQueryCmdError -> Text
renderShelleyQueryCmdError (PastHorizonException -> ShelleyQueryCmdError
ShelleyQueryCmdPastHorizon PastHorizonException
e)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ O.QueryTipLocalStateOutput
              { $sel:localStateChainTip:QueryTipLocalStateOutput :: ChainTip
O.localStateChainTip = ChainTip
chainTip
              , $sel:mEra:QueryTipLocalStateOutput :: Maybe AnyCardanoEra
O.mEra = forall a. Maybe a
Nothing
              , $sel:mEpoch:QueryTipLocalStateOutput :: Maybe EpochNo
O.mEpoch = forall a. Maybe a
Nothing
              , $sel:mSyncProgress:QueryTipLocalStateOutput :: Maybe Text
O.mSyncProgress = forall a. Maybe a
Nothing
              , $sel:mSlotInEpoch:QueryTipLocalStateOutput :: Maybe Word64
O.mSlotInEpoch = forall a. Maybe a
Nothing
              , $sel:mSlotsToEpochEnd:QueryTipLocalStateOutput :: Maybe Word64
O.mSlotsToEpochEnd = forall a. Maybe a
Nothing
              }

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

              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 <- forall e (m :: * -> *) a.
Monad m =>
Either e a -> (e -> m ()) -> m (Maybe a)
hushM Either ShelleyQueryCmdError Text
syncProgressResult forall a b. (a -> b) -> a -> b
$ \ShelleyQueryCmdError
e -> do
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
T.hPutStrLn Handle
IO.stderr forall a b. (a -> b) -> a -> b
$ Text
"Warning: Sync progress unavailable: " forall a. Semigroup a => a -> a -> a
<> ShelleyQueryCmdError -> Text
renderShelleyQueryCmdError ShelleyQueryCmdError
e

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

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

    ConsensusMode mode
mode -> forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (AnyConsensusMode -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedMode (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 [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> IO (Either AcquiringFailure AnyCardanoEra)
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)

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

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

  let query :: QueryInEra era (UTxO era)
query   = forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe (forall era.
QueryUTxOFilter -> QueryInShelleyBasedEra era (UTxO era)
QueryUTxO QueryUTxOFilter
qfilter)
      qInMode :: QueryInMode mode (Either EraMismatch (UTxO era))
qInMode = 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 <- 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

  forall era.
ShelleyBasedEra era
-> Maybe OutputFile
-> UTxO era
-> ExceptT ShelleyQueryCmdError IO ()
writeFilteredUTxOs ShelleyBasedEra era
sbe Maybe OutputFile
mOutFile UTxO era
result

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

  OperationalCertificate
opCert <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a.
HasTextEnvelope a =>
AsType a -> [Char] -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope AsType OperationalCertificate
AsOperationalCertificate [Char]
nodeOpCertFile)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileError TextEnvelopeError -> ShelleyQueryCmdError
ShelleyQueryCmdOpCertCounterReadError)

  SocketPath [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> IO (Either AcquiringFailure AnyCardanoEra)
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)

  let cMode :: ConsensusMode mode
cMode = forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams
  ShelleyBasedEra era
sbe <- forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe forall a b. (a -> b) -> a -> b
$ forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era
  case ConsensusMode mode
cMode of
    ConsensusMode mode
CardanoMode -> do
      EraInMode era mode
eInMode <- forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode
        forall a b. a -> (a -> b) -> b
& forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe (AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (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 = forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall a b. (a -> b) -> a -> b
$ forall era. QueryInShelleyBasedEra era GenesisParameters
QueryGenesisParameters
          eraHistoryQuery :: QueryInMode CardanoMode (EraHistory CardanoMode)
eraHistoryQuery = forall mode.
ConsensusModeIsMultiEra mode -> QueryInMode mode (EraHistory mode)
QueryEraHistory ConsensusModeIsMultiEra CardanoMode
CardanoModeIsMultiEra
      GenesisParameters
gParams <- 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode result.
LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> QueryInMode mode result
-> IO (Either AcquiringFailure result)
queryNodeLocalState LocalNodeConnectInfo mode
localNodeConnInfo forall a. Maybe a
Nothing QueryInMode CardanoMode (EraHistory CardanoMode)
eraHistoryQuery)
        forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)

      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 = forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall a b. (a -> b) -> a -> b
$ forall era. QueryInShelleyBasedEra era (ProtocolState era)
QueryProtocolState
      ProtocolState era
ptclState <- 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) <- 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,
     HashAnnotated
       (TxBody (ShelleyLedgerEra era))
       EraIndependentTxBody
       StandardCrypto) =>
    a)
-> a
eligibleLeaderSlotsConstaints ShelleyBasedEra era
sbe forall a b. (a -> b) -> a -> b
$ 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
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char] -> OpCertIntervalInformation -> [Char]
renderOpCertIntervalInformation [Char]
nodeOpCertFile OpCertIntervalInformation
opCertIntervalInformation
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char] -> OpCertNodeAndOnDiskCounterInformation -> [Char]
renderOpCertNodeAndOnDiskCounterInformation [Char]
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 = forall a. ToJSON a => a -> ByteString
encodePretty QueryKesPeriodInfoOutput
qKesInfoOutput

      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
LBS.putStrLn ByteString
kesPeriodInfoJSON
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe OutputFile
mOutFile (\(OutputFile [Char]
oFp) ->
        forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. [Char] -> IOException -> FileError e
FileIOError [Char]
oFp)
          forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
LBS.writeFile [Char]
oFp ByteString
kesPeriodInfoJSON)
    ConsensusMode mode
mode -> forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyConsensusMode -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedMode forall a b. (a -> b) -> a -> b
$ 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ GenesisParameters -> Int
protocolParamSlotsPerKESPeriod GenesisParameters
gParams
     in Word64 -> CurrentKesPeriod
CurrentKesPeriod forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
currSlot forall a. Integral a => a -> a -> a
`div` Word64
slotsPerKesPeriod

   opCertStartingKesPeriod :: OperationalCertificate -> OpCertStartingKesPeriod
   opCertStartingKesPeriod :: OperationalCertificate -> OpCertStartingKesPeriod
opCertStartingKesPeriod = Word64 -> OpCertStartingKesPeriod
OpCertStartingKesPeriod forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ GenesisParameters -> Int
protocolParamMaxKESEvolutions GenesisParameters
gParams
     in Word64 -> OpCertEndingKesPeriod
OpCertEndingKesPeriod forall a b. (a -> b) -> a -> b
$ Word64
start 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
SlotNo forall a b. (a -> b) -> a -> b
$ (Word64
oCertEnd forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (GenesisParameters -> Int
protocolParamSlotsPerKESPeriod GenesisParameters
gParams)) forall a. Num a => a -> a -> a
- Word64
cSlot
       in CurrentKesPeriod
-> OpCertStartingKesPeriod
-> OpCertEndingKesPeriod
-> Maybe SlotsTillKesKeyExpiry
-> OpCertIntervalInformation
O.createOpCertIntervalInfo CurrentKesPeriod
c OpCertStartingKesPeriod
s OpCertEndingKesPeriod
e (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 forall a. Ord a => a -> a -> Bool
< Word64
nsc = OpCertOnDiskCounter
-> OpCertNodeStateCounter -> OpCertNodeAndOnDiskCounterInformation
OpCertOnDiskCounterBehindNodeState OpCertOnDiskCounter
o OpCertNodeStateCounter
n
     | Word64
odc forall a. Ord a => a -> a -> Bool
> Word64
nsc forall a. Num a => a -> a -> a
+ Word64
1 = OpCertOnDiskCounter
-> OpCertNodeStateCounter -> OpCertNodeAndOnDiskCounterInformation
OpCertOnDiskCounterTooFarAheadOfNodeState OpCertOnDiskCounter
o OpCertNodeStateCounter
n
     | Word64
odc forall a. Eq a => a -> a -> Bool
== Word64
nsc forall a. Num a => a -> a -> a
+ Word64
1 = OpCertOnDiskCounter
-> OpCertNodeStateCounter -> OpCertNodeAndOnDiskCounterInformation
OpCertOnDiskCounterAheadOfNodeState OpCertOnDiskCounter
o OpCertNodeStateCounter
n
     | Bool
otherwise = OpCertOnDiskCounter
-> OpCertNodeStateCounter -> OpCertNodeAndOnDiskCounterInformation
OpCertOnDiskCounterEqualToNodeState 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 = forall (m :: * -> *).
(HasCallStack, Monad m) =>
EpochInfo m -> SystemStart -> SlotNo -> m UTCTime
epochInfoSlotToUTCTime
                  EpochInfo (Either Text)
eInfo
                  (UTCTime -> SystemStart
SystemStart forall a b. (a -> b) -> a -> b
$ GenesisParameters -> UTCTime
protocolParamSystemStart GenesisParameters
gParams)
                  (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word64
oCertExpiryKesPeriod forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (GenesisParameters -> Int
protocolParamSlotsPerKESPeriod GenesisParameters
gParams))
     in case Either Text UTCTime
time of
          Left Text
_ -> forall a. Maybe a
Nothing
          Right UTCTime
t -> forall a. a -> Maybe a
Just UTCTime
t

   renderOpCertNodeAndOnDiskCounterInformation :: FilePath -> OpCertNodeAndOnDiskCounterInformation -> String
   renderOpCertNodeAndOnDiskCounterInformation :: [Char] -> OpCertNodeAndOnDiskCounterInformation -> [Char]
renderOpCertNodeAndOnDiskCounterInformation [Char]
opCertFile OpCertNodeAndOnDiskCounterInformation
opCertCounterInfo =
     case OpCertNodeAndOnDiskCounterInformation
opCertCounterInfo of
      OpCertOnDiskCounterEqualToNodeState OpCertOnDiskCounter
_ OpCertNodeStateCounter
_ ->
        Doc AnsiStyle -> [Char]
renderStringDefault forall a b. (a -> b) -> a -> b
$
          Doc AnsiStyle -> Doc AnsiStyle
green Doc AnsiStyle
"✓" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> Doc ann -> Doc ann
hang Int
0
              ( forall ann. [Doc ann] -> Doc ann
vsep
                [ Doc AnsiStyle
"The operational certificate counter agrees with the node protocol state counter"
                ]
              )
      OpCertOnDiskCounterAheadOfNodeState OpCertOnDiskCounter
_ OpCertNodeStateCounter
_ ->
        Doc AnsiStyle -> [Char]
renderStringDefault forall a b. (a -> b) -> a -> b
$
          Doc AnsiStyle -> Doc AnsiStyle
green Doc AnsiStyle
"✓" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> Doc ann -> Doc ann
hang Int
0
              ( forall ann. [Doc ann] -> Doc ann
vsep
                [ Doc AnsiStyle
"The operational certificate counter ahead of the node protocol state counter by 1"
                ]
              )
      OpCertOnDiskCounterTooFarAheadOfNodeState OpCertOnDiskCounter
onDiskC OpCertNodeStateCounter
nodeStateC ->
        Doc AnsiStyle -> [Char]
renderStringDefault forall a b. (a -> b) -> a -> b
$
          Doc AnsiStyle -> Doc AnsiStyle
red Doc AnsiStyle
"✗" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> Doc ann -> Doc ann
hang Int
0
            ( forall ann. [Doc ann] -> Doc ann
vsep
              [ Doc AnsiStyle
"The operational certificate counter too far ahead of the node protocol state counter in the operational certificate at: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty [Char]
opCertFile
              , Doc AnsiStyle
"On disk operational certificate counter: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (OpCertOnDiskCounter -> Word64
unOpCertOnDiskCounter OpCertOnDiskCounter
onDiskC)
              , Doc AnsiStyle
"Protocol state counter: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (OpCertNodeStateCounter -> Word64
unOpCertNodeStateCounter OpCertNodeStateCounter
nodeStateC)
              ]
            )
      OpCertOnDiskCounterBehindNodeState OpCertOnDiskCounter
onDiskC OpCertNodeStateCounter
nodeStateC ->
        Doc AnsiStyle -> [Char]
renderStringDefault forall a b. (a -> b) -> a -> b
$
          Doc AnsiStyle -> Doc AnsiStyle
red Doc AnsiStyle
"✗" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> Doc ann -> Doc ann
hang Int
0
            ( forall ann. [Doc ann] -> Doc ann
vsep
              [ Doc AnsiStyle
"The protocol state counter is greater than the counter in the operational certificate at: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty [Char]
opCertFile
              , Doc AnsiStyle
"On disk operational certificate counter: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (OpCertOnDiskCounter -> Word64
unOpCertOnDiskCounter OpCertOnDiskCounter
onDiskC)
              , Doc AnsiStyle
"Protocol state counter: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (OpCertNodeStateCounter -> Word64
unOpCertNodeStateCounter OpCertNodeStateCounter
nodeStateC)
              ]
            )
      OpCertNoBlocksMintedYet (OpCertOnDiskCounter Word64
onDiskC) ->
        Doc AnsiStyle -> [Char]
renderStringDefault forall a b. (a -> b) -> a -> b
$
          Doc AnsiStyle -> Doc AnsiStyle
red Doc AnsiStyle
"✗" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> Doc ann -> Doc ann
hang Int
0
            ( forall ann. [Doc ann] -> Doc ann
vsep
              [ Doc AnsiStyle
"No blocks minted so far with the operational certificate at: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty [Char]
opCertFile
              , Doc AnsiStyle
"On disk operational certificate counter: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty 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, forall a. a -> Maybe a
Just SlotsTillKesKeyExpiry
sTillExp)
                            OpCertStartingKesPeriodIsInTheFuture OpCertStartingKesPeriod
_ OpCertEndingKesPeriod
end CurrentKesPeriod
_ -> (OpCertEndingKesPeriod
end, forall a. Maybe a
Nothing)
                            OpCertExpired OpCertStartingKesPeriod
_ OpCertEndingKesPeriod
end CurrentKesPeriod
_ -> (OpCertEndingKesPeriod
end, forall a. Maybe a
Nothing)
                            OpCertSomeOtherError OpCertStartingKesPeriod
_ OpCertEndingKesPeriod
end CurrentKesPeriod
_ -> (OpCertEndingKesPeriod
end, forall a. Maybe a
Nothing)
         (OpCertOnDiskCounter
onDiskCounter, Maybe OpCertNodeStateCounter
mNodeCounter) = case OpCertNodeAndOnDiskCounterInformation
oCertCounterInfo of
                                           OpCertOnDiskCounterEqualToNodeState OpCertOnDiskCounter
d OpCertNodeStateCounter
n -> (OpCertOnDiskCounter
d, forall a. a -> Maybe a
Just OpCertNodeStateCounter
n)
                                           OpCertOnDiskCounterAheadOfNodeState OpCertOnDiskCounter
d OpCertNodeStateCounter
n -> (OpCertOnDiskCounter
d, forall a. a -> Maybe a
Just OpCertNodeStateCounter
n)
                                           OpCertOnDiskCounterTooFarAheadOfNodeState OpCertOnDiskCounter
d OpCertNodeStateCounter
n -> (OpCertOnDiskCounter
d, forall a. a -> Maybe a
Just OpCertNodeStateCounter
n)
                                           OpCertOnDiskCounterBehindNodeState OpCertOnDiskCounter
d OpCertNodeStateCounter
n -> (OpCertOnDiskCounter
d, forall a. a -> Maybe a
Just OpCertNodeStateCounter
n)
                                           OpCertNoBlocksMintedYet OpCertOnDiskCounter
d -> (OpCertOnDiskCounter
d, forall a. Maybe a
Nothing)

     in 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ GenesisParameters -> Int
protocolParamMaxKESEvolutions GenesisParameters
gParams
        , $sel:qKesInfoSlotsPerKesPeriod:QueryKesPeriodInfoOutput :: Word64
O.qKesInfoSlotsPerKesPeriod = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 -> 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 :: 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 opCert :: OperationalCertificate
opCert@(OperationalCertificate OCert StandardCrypto
_ VerificationKey StakePoolKey
stakePoolVKey) = do
    let onDiskOpCertCount :: Word64
onDiskOpCertCount = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ OperationalCertificate -> Word64
getOpCertCount OperationalCertificate
opCert

    ChainDepState (ConsensusProtocol era)
chainDepState <- forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era.
FromCBOR (ChainDepState (ConsensusProtocol era)) =>
ProtocolState era
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
decodeProtocolState ProtocolState era
ptclState)
      forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, DecoderError) -> ShelleyQueryCmdError
ShelleyQueryCmdProtocolStateDecodeFailure)

    -- 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 = forall p (proxy :: * -> *).
PraosProtocolSupportsNode p =>
proxy p
-> ChainDepState p
-> Map
     (KeyHash 'BlockIssuer (PraosProtocolSupportsNodeCrypto p)) Word64
Consensus.getOpCertCounters (forall {k} (t :: k). Proxy t
Proxy @(ConsensusProtocol era)) ChainDepState (ConsensusProtocol era)
chainDepState
        StakePoolKeyHash KeyHash 'StakePool StandardCrypto
blockIssuerHash = forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey StakePoolKey
stakePoolVKey

    case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (coerce :: forall a b. Coercible a b => a -> b
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> OpCertOnDiskCounter
OpCertOnDiskCounter Word64
onDiskOpCertCount, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Word64 -> OpCertNodeStateCounter
OpCertNodeStateCounter Word64
ptclStateCounter)
      Maybe Word64
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> OpCertOnDiskCounter
OpCertOnDiskCounter Word64
onDiskOpCertCount, forall a. Maybe a
Nothing)


renderOpCertIntervalInformation :: FilePath -> OpCertIntervalInformation -> String
renderOpCertIntervalInformation :: [Char] -> OpCertIntervalInformation -> [Char]
renderOpCertIntervalInformation [Char]
opCertFile OpCertIntervalInformation
opCertInfo = case OpCertIntervalInformation
opCertInfo of
  OpCertWithinInterval OpCertStartingKesPeriod
_start OpCertEndingKesPeriod
_end CurrentKesPeriod
_current SlotsTillKesKeyExpiry
_stillExp ->
    Doc AnsiStyle -> [Char]
renderStringDefault forall a b. (a -> b) -> a -> b
$
      Doc AnsiStyle -> Doc AnsiStyle
green Doc AnsiStyle
"✓" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> Doc ann -> Doc ann
hang Int
0
        ( forall ann. [Doc ann] -> Doc ann
vsep
          [ Doc AnsiStyle
"Operational certificate's KES period is within the correct KES period interval"
          ]
        )
  OpCertStartingKesPeriodIsInTheFuture (OpCertStartingKesPeriod Word64
start) (OpCertEndingKesPeriod Word64
end) (CurrentKesPeriod Word64
current) ->
    Doc AnsiStyle -> [Char]
renderStringDefault forall a b. (a -> b) -> a -> b
$
      Doc AnsiStyle -> Doc AnsiStyle
red Doc AnsiStyle
"✗" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> Doc ann -> Doc ann
hang Int
0
        ( forall ann. [Doc ann] -> Doc ann
vsep
          [ Doc AnsiStyle
"Node operational certificate at: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty [Char]
opCertFile forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" has an incorrectly specified starting KES period. "
          , Doc AnsiStyle
"Current KES period: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Word64
current
          , Doc AnsiStyle
"Operational certificate's starting KES period: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Word64
start
          , Doc AnsiStyle
"Operational certificate's expiry KES period: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Word64
end
          ]
        )
  OpCertExpired OpCertStartingKesPeriod
_ (OpCertEndingKesPeriod Word64
end) (CurrentKesPeriod Word64
current) ->
    Doc AnsiStyle -> [Char]
renderStringDefault forall a b. (a -> b) -> a -> b
$
      Doc AnsiStyle -> Doc AnsiStyle
red Doc AnsiStyle
"✗" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> Doc ann -> Doc ann
hang Int
0
        ( forall ann. [Doc ann] -> Doc ann
vsep
          [ Doc AnsiStyle
"Node operational certificate at: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty [Char]
opCertFile forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" has expired. "
          , Doc AnsiStyle
"Current KES period: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Word64
current
          , Doc AnsiStyle
"Operational certificate's expiry KES period: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Word64
end
          ]
        )

  OpCertSomeOtherError (OpCertStartingKesPeriod Word64
start) (OpCertEndingKesPeriod Word64
end) (CurrentKesPeriod Word64
current) ->
    Doc AnsiStyle -> [Char]
renderStringDefault forall a b. (a -> b) -> a -> b
$
      Doc AnsiStyle -> Doc AnsiStyle
red Doc AnsiStyle
"✗" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Int -> Doc ann -> Doc ann
hang Int
0
        ( forall ann. [Doc ann] -> Doc ann
vsep
          [ Doc AnsiStyle
"An unknown error occurred with operational certificate at: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty [Char]
opCertFile
          , Doc AnsiStyle
"Current KES period: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Word64
current
          , Doc AnsiStyle
"Operational certificate's starting KES period: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Word64
start
          , Doc AnsiStyle
"Operational certificate's expiry KES period: " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty 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).
--
runQueryPoolState
  :: AnyConsensusModeParams
  -> NetworkId
  -> [Hash StakePoolKey]
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryPoolState :: AnyConsensusModeParams
-> NetworkId -> [PoolId] -> ExceptT ShelleyQueryCmdError IO ()
runQueryPoolState (AnyConsensusModeParams ConsensusModeParams mode
cModeParams) NetworkId
network [PoolId]
poolIds = do
  SocketPath [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> IO (Either AcquiringFailure AnyCardanoEra)
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)

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

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

  let qInMode :: QueryInMode mode (Either EraMismatch (SerialisedPoolState era))
qInMode = forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall a b. (a -> b) -> a -> b
$ forall era.
Maybe (Set PoolId)
-> QueryInShelleyBasedEra era (SerialisedPoolState era)
QueryPoolState forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [PoolId]
poolIds
  SerialisedPoolState era
result <- 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 (SerialisedPoolState era))
qInMode
  forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((ToJSON (DebugLedgerState era),
     FromCBOR (DebugLedgerState era), Crypto ledgerera ~ StandardCrypto,
     Era (ShelleyLedgerEra era)) =>
    a)
-> a
obtainLedgerEraClassConstraints ShelleyBasedEra era
sbe forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto, Era ledgerera) =>
SerialisedPoolState era -> ExceptT ShelleyQueryCmdError IO ()
writePoolState SerialisedPoolState era
result

-- | Query the local mempool state
runQueryTxMempool
  :: AnyConsensusModeParams
  -> NetworkId
  -> TxMempoolQuery
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryTxMempool :: AnyConsensusModeParams
-> NetworkId
-> TxMempoolQuery
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryTxMempool (AnyConsensusModeParams ConsensusModeParams mode
cModeParams) NetworkId
network TxMempoolQuery
query Maybe OutputFile
mOutFile = do
  SocketPath [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

  LocalTxMonitoringQuery mode
localQuery <- case TxMempoolQuery
query of
      TxMempoolQueryTxExists TxId
tx -> do
        anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> IO (Either AcquiringFailure AnyCardanoEra)
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo)
          forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)
        let cMode :: ConsensusMode mode
cMode = forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams
        EraInMode era mode
eInMode <- forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
cMode
          forall a b. a -> (a -> b) -> b
& forall (m :: * -> *) x a. Monad m => x -> Maybe a -> ExceptT x m a
hoistMaybe (AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
cMode) AnyCardanoEra
anyE)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall mode. TxIdInMode mode -> LocalTxMonitoringQuery mode
LocalTxMonitoringQueryTx forall a b. (a -> b) -> a -> b
$ forall era mode. TxId -> EraInMode era mode -> TxIdInMode mode
TxIdInMode TxId
tx EraInMode era mode
eInMode
      TxMempoolQuery
TxMempoolQueryNextTx -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall mode. LocalTxMonitoringQuery mode
LocalTxMonitoringSendNextTx
      TxMempoolQuery
TxMempoolQueryInfo -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall mode. LocalTxMonitoringQuery mode
LocalTxMonitoringMempoolInformation

  LocalTxMonitoringResult mode
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall mode.
LocalNodeConnectInfo mode
-> LocalTxMonitoringQuery mode -> IO (LocalTxMonitoringResult mode)
queryTxMonitoringLocal LocalNodeConnectInfo mode
localNodeConnInfo LocalTxMonitoringQuery mode
localQuery
  let renderedResult :: ByteString
renderedResult = forall a. ToJSON a => a -> ByteString
encodePretty LocalTxMonitoringResult mode
result
  case Maybe OutputFile
mOutFile of
    Maybe OutputFile
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
LBS.putStrLn ByteString
renderedResult
    Just (OutputFile [Char]
oFp) -> forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. [Char] -> IOException -> FileError e
FileIOError [Char]
oFp)
        forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
LBS.writeFile [Char]
oFp ByteString
renderedResult


-- | 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
  -> AllOrOnly [Hash StakePoolKey]
  -> Maybe OutputFile
  -> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeSnapshot :: AnyConsensusModeParams
-> NetworkId
-> AllOrOnly [PoolId]
-> Maybe OutputFile
-> ExceptT ShelleyQueryCmdError IO ()
runQueryStakeSnapshot (AnyConsensusModeParams ConsensusModeParams mode
cModeParams) NetworkId
network AllOrOnly [PoolId]
allOrOnlyPoolIds Maybe OutputFile
mOutFile = do
  SocketPath [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> IO (Either AcquiringFailure AnyCardanoEra)
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)

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

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

  let qInMode :: QueryInMode
  mode (Either EraMismatch (SerialisedStakeSnapshots era))
qInMode = forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall a b. (a -> b) -> a -> b
$ forall era.
Maybe (Set PoolId)
-> QueryInShelleyBasedEra era (SerialisedStakeSnapshots era)
QueryStakeSnapshot forall a b. (a -> b) -> a -> b
$ case AllOrOnly [PoolId]
allOrOnlyPoolIds of
        AllOrOnly [PoolId]
All -> forall a. Maybe a
Nothing
        Only [PoolId]
poolIds -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [PoolId]
poolIds

  SerialisedStakeSnapshots era
result <- 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 (SerialisedStakeSnapshots era))
qInMode
  forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((ToJSON (DebugLedgerState era),
     FromCBOR (DebugLedgerState era), Crypto ledgerera ~ StandardCrypto,
     Era (ShelleyLedgerEra era)) =>
    a)
-> a
obtainLedgerEraClassConstraints ShelleyBasedEra era
sbe (forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto) =>
Maybe OutputFile
-> SerialisedStakeSnapshots era
-> ExceptT ShelleyQueryCmdError IO ()
writeStakeSnapshots Maybe OutputFile
mOutFile) SerialisedStakeSnapshots 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 [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> IO (Either AcquiringFailure AnyCardanoEra)
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)

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

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

  let qInMode :: QueryInMode
  mode (Either EraMismatch (SerialisedDebugLedgerState era))
qInMode = forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall a b. (a -> b) -> a -> b
$ forall era.
QueryInShelleyBasedEra era (SerialisedDebugLedgerState era)
QueryDebugLedgerState

  SerialisedDebugLedgerState era
result <- 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

  forall era ledgerera a.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era
-> ((ToJSON (DebugLedgerState era),
     FromCBOR (DebugLedgerState era), Crypto ledgerera ~ StandardCrypto,
     Era (ShelleyLedgerEra era)) =>
    a)
-> a
obtainLedgerEraClassConstraints ShelleyBasedEra era
sbe (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

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 [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> IO (Either AcquiringFailure AnyCardanoEra)
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)

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

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

  let qInMode :: QueryInMode mode (Either EraMismatch (ProtocolState era))
qInMode = forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall a b. (a -> b) -> a -> b
$ forall era. QueryInShelleyBasedEra era (ProtocolState era)
QueryProtocolState

  ProtocolState era
result <- 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 -> forall era a.
ShelleyBasedEra era
-> ((FromCBOR (ChainDepState (ConsensusProtocol era)),
     ToJSON (ChainDepState (ConsensusProtocol era))) =>
    a)
-> a
eligibleWriteProtocolStateConstaints ShelleyBasedEra era
sbe forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyConsensusMode -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedMode forall a b. (a -> b) -> a -> b
$ forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode ConsensusMode mode
mode

-- | 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 [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> IO (Either AcquiringFailure AnyCardanoEra)
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)

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

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

  let stakeAddr :: Set StakeCredential
stakeAddr = forall a. a -> Set a
Set.singleton 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 PoolId))
query = forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall a b. (a -> b) -> a -> b
$ forall era.
Set StakeCredential
-> NetworkId
-> QueryInShelleyBasedEra
     era (Map StakeAddress Lovelace, Map StakeAddress PoolId)
QueryStakeAddresses Set StakeCredential
stakeAddr NetworkId
network

  (Map StakeAddress Lovelace, Map StakeAddress PoolId)
result <- 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 PoolId))
query

  Maybe OutputFile
-> DelegationsAndRewards -> ExceptT ShelleyQueryCmdError IO ()
writeStakeAddressInfo Maybe OutputFile
mOutFile forall a b. (a -> b) -> a -> b
$ (Map StakeAddress Lovelace, Map StakeAddress PoolId)
-> DelegationsAndRewards
DelegationsAndRewards (Map StakeAddress Lovelace, Map StakeAddress PoolId)
result

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

-- | 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
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ShelleyQueryCmdLocalStateQueryError] -> ShowS
$cshowList :: [ShelleyQueryCmdLocalStateQueryError] -> ShowS
show :: ShelleyQueryCmdLocalStateQueryError -> [Char]
$cshow :: ShelleyQueryCmdLocalStateQueryError -> [Char]
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: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow AcquireFailure
err
    EraMismatchError EraMismatch
err ->
      Text
"A query from a certain era was applied to a ledger from a different era: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
textShow 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, "
     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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
LBS.putStrLn (forall a. ToJSON a => a -> ByteString
encodePretty DelegationsAndRewards
delegsAndRewards)
    Just (OutputFile [Char]
fpath) ->
      forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. [Char] -> IOException -> FileError e
FileIOError [Char]
fpath)
        forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
LBS.writeFile [Char]
fpath (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 :: forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera, ToJSON (DebugLedgerState era),
 FromCBOR (DebugLedgerState era)) =>
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 forall era.
FromCBOR (DebugLedgerState era) =>
SerialisedDebugLedgerState era
-> Either ByteString (DebugLedgerState era)
decodeDebugLedgerState SerialisedDebugLedgerState era
qState of
        Left ByteString
bs -> forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT HelpersError -> ShelleyQueryCmdError
ShelleyQueryCmdHelpersError forall a b. (a -> b) -> a -> b
$ ByteString -> ExceptT HelpersError IO ()
pPrintCBOR ByteString
bs
        Right DebugLedgerState era
ledgerState -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
LBS.putStrLn forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
Aeson.encode DebugLedgerState era
ledgerState
    Just (OutputFile [Char]
fpath) ->
      forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. [Char] -> IOException -> FileError e
FileIOError [Char]
fpath)
        forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
LBS.writeFile [Char]
fpath forall a b. (a -> b) -> a -> b
$ forall a. Serialised a -> ByteString
unSerialised Serialised (NewEpochState (ShelleyLedgerEra era))
serLedgerState

writeStakeSnapshots :: forall era ledgerera. ()
  => ShelleyLedgerEra era ~ ledgerera
  => Era.Crypto ledgerera ~ StandardCrypto
  => Maybe OutputFile
  -> SerialisedStakeSnapshots era
  -> ExceptT ShelleyQueryCmdError IO ()
writeStakeSnapshots :: forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto) =>
Maybe OutputFile
-> SerialisedStakeSnapshots era
-> ExceptT ShelleyQueryCmdError IO ()
writeStakeSnapshots Maybe OutputFile
mOutFile SerialisedStakeSnapshots era
qState = do
  StakeSnapshot StakeSnapshots (Crypto (ShelleyLedgerEra era))
snapshot <- forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era.
FromCBOR (StakeSnapshots (Crypto (ShelleyLedgerEra era))) =>
SerialisedStakeSnapshots era
-> Either DecoderError (StakeSnapshot era)
decodeStakeSnapshot SerialisedStakeSnapshots era
qState)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoderError -> ShelleyQueryCmdError
ShelleyQueryCmdStakeSnapshotDecodeError)

  -- Calculate the three pool and active stake values for the given pool
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString -> IO ()
LBS.putStrLn ([Char] -> ByteString -> IO ()
LBS.writeFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputFile -> [Char]
unOutputFile) Maybe OutputFile
mOutFile forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encodePretty StakeSnapshots (Crypto (ShelleyLedgerEra era))
snapshot

-- | 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>
writePoolState :: forall era ledgerera. ()
  => ShelleyLedgerEra era ~ ledgerera
  => Era.Crypto ledgerera ~ StandardCrypto
  => Ledger.Era ledgerera
  => SerialisedPoolState era
  -> ExceptT ShelleyQueryCmdError IO ()
writePoolState :: forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 Crypto ledgerera ~ StandardCrypto, Era ledgerera) =>
SerialisedPoolState era -> ExceptT ShelleyQueryCmdError IO ()
writePoolState SerialisedPoolState era
serialisedCurrentEpochState = do
  PoolState PState (Crypto (ShelleyLedgerEra era))
poolState <- forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era.
FromCBOR (PState (Crypto (ShelleyLedgerEra era))) =>
SerialisedPoolState era -> Either DecoderError (PoolState era)
decodePoolState SerialisedPoolState era
serialisedCurrentEpochState)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoderError -> ShelleyQueryCmdError
ShelleyQueryCmdPoolStateDecodeError)

  let hks :: [KeyHash 'StakePool StandardCrypto]
hks = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys (forall crypto.
PState crypto
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_pParams PState (Crypto (ShelleyLedgerEra era))
poolState) forall a. Semigroup a => a -> a -> a
<> forall k a. Map k a -> [k]
Map.keys (forall crypto.
PState crypto
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
_fPParams PState (Crypto (ShelleyLedgerEra era))
poolState) forall a. Semigroup a => a -> a -> a
<> forall k a. Map k a -> [k]
Map.keys (forall crypto.
PState crypto -> Map (KeyHash 'StakePool crypto) EpochNo
_retiring PState (Crypto (ShelleyLedgerEra era))
poolState)

  let poolStates :: Map (KeyHash 'StakePool StandardCrypto) (Params StandardCrypto)
      poolStates :: Map (KeyHash 'StakePool StandardCrypto) (Params StandardCrypto)
poolStates = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ [KeyHash 'StakePool StandardCrypto]
hks forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
        ( \KeyHash 'StakePool StandardCrypto
hk ->
          ( KeyHash 'StakePool StandardCrypto
hk
          , Params
            { poolParameters :: Maybe (PoolParams StandardCrypto)
poolParameters        = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool StandardCrypto
hk (forall crypto.
PState crypto
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
SL._pParams  PState (Crypto (ShelleyLedgerEra era))
poolState)
            , futurePoolParameters :: Maybe (PoolParams StandardCrypto)
futurePoolParameters  = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool StandardCrypto
hk (forall crypto.
PState crypto
-> Map (KeyHash 'StakePool crypto) (PoolParams crypto)
SL._fPParams PState (Crypto (ShelleyLedgerEra era))
poolState)
            , retiringEpoch :: Maybe EpochNo
retiringEpoch         = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool StandardCrypto
hk (forall crypto.
PState crypto -> Map (KeyHash 'StakePool crypto) EpochNo
SL._retiring PState (Crypto (ShelleyLedgerEra era))
poolState)
            }
          )
        )

  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
LBS.putStrLn forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encodePretty Map (KeyHash 'StakePool StandardCrypto) (Params StandardCrypto)
poolStates

writeProtocolState ::
  ( FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
  , ToJSON (Consensus.ChainDepState (ConsensusProtocol era))
  )
  => Maybe OutputFile
  -> ProtocolState era
  -> ExceptT ShelleyQueryCmdError IO ()
writeProtocolState :: forall era.
(FromCBOR (ChainDepState (ConsensusProtocol era)),
 ToJSON (ChainDepState (ConsensusProtocol era))) =>
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 forall era.
FromCBOR (ChainDepState (ConsensusProtocol era)) =>
ProtocolState era
-> Either
     (ByteString, DecoderError) (ChainDepState (ConsensusProtocol era))
decodeProtocolState ProtocolState era
ps of
      Left (ByteString
bs, DecoderError
_) -> forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT HelpersError -> ShelleyQueryCmdError
ShelleyQueryCmdHelpersError forall a b. (a -> b) -> a -> b
$ ByteString -> ExceptT HelpersError IO ()
pPrintCBOR ByteString
bs
      Right ChainDepState (ConsensusProtocol era)
chainDepstate -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
LBS.putStrLn forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encodePretty ChainDepState (ConsensusProtocol era)
chainDepstate
    Just (OutputFile [Char]
fpath) ->
      forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. [Char] -> IOException -> FileError e
FileIOError [Char]
fpath)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString -> IO ()
LBS.writeFile [Char]
fpath forall a b. (a -> b) -> a -> b
$ forall a. Serialised a -> ByteString
unSerialised Serialised (ChainDepState (ConsensusProtocol era))
pstate

writeFilteredUTxOs :: Api.ShelleyBasedEra era
                   -> Maybe OutputFile
                   -> UTxO era
                   -> ExceptT ShelleyQueryCmdError IO ()
writeFilteredUTxOs :: forall era.
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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall era. ShelleyBasedEra era -> UTxO era -> IO ()
printFilteredUTxOs ShelleyBasedEra era
shelleyBasedEra' UTxO era
utxo
      Just (OutputFile [Char]
fpath) ->
        case ShelleyBasedEra era
shelleyBasedEra' of
          ShelleyBasedEra era
ShelleyBasedEraShelley -> forall {m :: * -> *} {a}.
(MonadIO m, ToJSON a) =>
[Char] -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo [Char]
fpath UTxO era
utxo
          ShelleyBasedEra era
ShelleyBasedEraAllegra -> forall {m :: * -> *} {a}.
(MonadIO m, ToJSON a) =>
[Char] -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo [Char]
fpath UTxO era
utxo
          ShelleyBasedEra era
ShelleyBasedEraMary -> forall {m :: * -> *} {a}.
(MonadIO m, ToJSON a) =>
[Char] -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo [Char]
fpath UTxO era
utxo
          ShelleyBasedEra era
ShelleyBasedEraAlonzo -> forall {m :: * -> *} {a}.
(MonadIO m, ToJSON a) =>
[Char] -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo [Char]
fpath UTxO era
utxo
          ShelleyBasedEra era
ShelleyBasedEraBabbage -> forall {m :: * -> *} {a}.
(MonadIO m, ToJSON a) =>
[Char] -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo [Char]
fpath UTxO era
utxo
          ShelleyBasedEra era
ShelleyBasedEraConway -> forall {m :: * -> *} {a}.
(MonadIO m, ToJSON a) =>
[Char] -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo [Char]
fpath UTxO era
utxo
 where
   writeUTxo :: [Char] -> a -> ExceptT ShelleyQueryCmdError m ()
writeUTxo [Char]
fpath a
utxo' =
     forall (m :: * -> *) x a.
MonadIO m =>
(IOException -> x) -> IO a -> ExceptT x m a
handleIOExceptT (FileError () -> ShelleyQueryCmdError
ShelleyQueryCmdWriteFileError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. [Char] -> IOException -> FileError e
FileIOError [Char]
fpath)
       forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
LBS.writeFile [Char]
fpath (forall a. ToJSON a => a -> ByteString
encodePretty a
utxo')

printFilteredUTxOs :: Api.ShelleyBasedEra era -> UTxO era -> IO ()
printFilteredUTxOs :: forall era. ShelleyBasedEra era -> UTxO era -> IO ()
printFilteredUTxOs ShelleyBasedEra era
shelleyBasedEra' (UTxO Map TxIn (TxOut CtxUTxO era)
utxo) = do
  Text -> IO ()
Text.putStrLn Text
title
  [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (Text -> Int
Text.length Text
title forall a. Num a => a -> a -> a
+ Int
2) Char
'-'
  case ShelleyBasedEra era
shelleyBasedEra' of
    ShelleyBasedEra era
ShelleyBasedEraShelley ->
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall era.
ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra') forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO era)
utxo
    ShelleyBasedEra era
ShelleyBasedEraAllegra ->
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall era.
ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra') forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO era)
utxo
    ShelleyBasedEra era
ShelleyBasedEraMary    ->
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall era.
ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra') forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO era)
utxo
    ShelleyBasedEra era
ShelleyBasedEraAlonzo ->
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall era.
ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra') forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO era)
utxo
    ShelleyBasedEra era
ShelleyBasedEraBabbage ->
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall era.
ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra') forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO era)
utxo
    ShelleyBasedEra era
ShelleyBasedEraConway ->
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall era.
ShelleyBasedEra era -> (TxIn, TxOut CtxUTxO era) -> IO ()
printUtxo ShelleyBasedEra era
shelleyBasedEra') forall a b. (a -> b) -> a -> b
$ 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 :: forall era.
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 forall a b. (a -> b) -> a -> b
$
           forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> Text
Text.decodeLatin1 (forall h a. Hash h a -> ByteString
hashToBytesAsHex Hash StandardCrypto EraIndependentTxBody
txhash)
             , forall a. Show a => Int -> a -> Text
textShowN Int
6 Word
index
             , Text
"        " forall a. Semigroup a => a -> a -> a
<> 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 forall a b. (a -> b) -> a -> b
$
           forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> Text
Text.decodeLatin1 (forall h a. Hash h a -> ByteString
hashToBytesAsHex Hash StandardCrypto EraIndependentTxBody
txhash)
             , forall a. Show a => Int -> a -> Text
textShowN Int
6 Word
index
             , Text
"        " forall a. Semigroup a => a -> a -> a
<> 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 forall a b. (a -> b) -> a -> b
$
           forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> Text
Text.decodeLatin1 (forall h a. Hash h a -> ByteString
hashToBytesAsHex Hash StandardCrypto EraIndependentTxBody
txhash)
             , forall a. Show a => Int -> a -> Text
textShowN Int
6 Word
index
             , Text
"        " forall a. Semigroup a => a -> a -> a
<> 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 forall a b. (a -> b) -> a -> b
$
           forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> Text
Text.decodeLatin1 (forall h a. Hash h a -> ByteString
hashToBytesAsHex Hash StandardCrypto EraIndependentTxBody
txhash)
             , forall a. Show a => Int -> a -> Text
textShowN Int
6 Word
index
             , Text
"        " forall a. Semigroup a => a -> a -> a
<> forall era. TxOutValue era -> Text
printableValue TxOutValue era
value forall a. Semigroup a => a -> a -> a
<> Text
" + " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. Show a => a -> [Char]
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 forall a b. (a -> b) -> a -> b
$
           forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> Text
Text.decodeLatin1 (forall h a. Hash h a -> ByteString
hashToBytesAsHex Hash StandardCrypto EraIndependentTxBody
txhash)
             , forall a. Show a => Int -> a -> Text
textShowN Int
6 Word
index
             , Text
"        " forall a. Semigroup a => a -> a -> a
<> forall era. TxOutValue era -> Text
printableValue TxOutValue era
value forall a. Semigroup a => a -> a -> a
<> Text
" + " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. Show a => a -> [Char]
show TxOutDatum CtxUTxO era
mDatum)
             ]
    ShelleyBasedEra era
ShelleyBasedEraConway ->
      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 forall a b. (a -> b) -> a -> b
$
           forall a. Monoid a => [a] -> a
mconcat
             [ ByteString -> Text
Text.decodeLatin1 (forall h a. Hash h a -> ByteString
hashToBytesAsHex Hash StandardCrypto EraIndependentTxBody
txhash)
             , forall a. Show a => Int -> a -> Text
textShowN Int
6 Word
index
             , Text
"        " forall a. Semigroup a => a -> a -> a
<> forall era. TxOutValue era -> Text
printableValue TxOutValue era
value forall a. Semigroup a => a -> a -> a
<> Text
" + " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack (forall a. Show a => a -> [Char]
show TxOutDatum CtxUTxO era
mDatum)
             ]
 where
  textShowN :: Show a => Int -> a -> Text
  textShowN :: forall a. Show a => Int -> a -> Text
textShowN Int
len a
x =
    let str :: [Char]
str = forall a. Show a => a -> [Char]
show a
x
        slen :: Int
slen = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
str
    in [Char] -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (forall a. Ord a => a -> a -> a
max Int
1 (Int
len forall a. Num a => a -> a -> a
- Int
slen)) Char
' ' forall a. [a] -> [a] -> [a]
++ [Char]
str

  printableValue :: TxOutValue era -> Text
  printableValue :: forall era. TxOutValue era -> Text
printableValue (TxOutValue MultiAssetSupportedInEra era
_ Value
val) = Value -> Text
renderValue Value
val
  printableValue (TxOutAdaOnly OnlyAdaSupportedInEra era
_ (Lovelace Integer
i)) = [Char] -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
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 [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

  Set PoolId
poolIds <-
    ( forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall mode a.
LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> LocalStateQueryExpr
     (BlockInMode mode) ChainPoint (QueryInMode mode) () IO a
-> IO (Either AcquiringFailure a)
executeLocalStateQueryExpr LocalNodeConnectInfo mode
localNodeConnInfo forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT @ShelleyQueryCmdError forall a b. (a -> b) -> a -> b
$ do
        anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- case forall mode. ConsensusModeParams mode -> ConsensusMode mode
consensusModeOnly ConsensusModeParams mode
cModeParams of
          ConsensusMode mode
ByronMode -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall era. IsCardanoEra era => CardanoEra era -> AnyCardanoEra
AnyCardanoEra CardanoEra ByronEra
ByronEra
          ConsensusMode mode
ShelleyMode -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall era. IsCardanoEra era => CardanoEra era -> AnyCardanoEra
AnyCardanoEra CardanoEra ShelleyEra
ShelleyEra
          ConsensusMode mode
CardanoMode ->
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr
     block
     point
     (QueryInMode mode)
     r
     IO
     (Either UnsupportedNtcVersionError a)
queryExpr forall a b. (a -> b) -> a -> b
$ forall mode.
ConsensusModeIsMultiEra mode -> QueryInMode mode AnyCardanoEra
QueryCurrentEra ConsensusModeIsMultiEra CardanoMode
CardanoModeIsMultiEra)
              forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnsupportedNtcVersionError -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedNtcVersion)

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

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

        ShelleyBasedEra era
sbe <- forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe forall a b. (a -> b) -> a -> b
$ forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era

        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode a block point r.
QueryInMode mode a
-> LocalStateQueryExpr
     block
     point
     (QueryInMode mode)
     r
     IO
     (Either UnsupportedNtcVersionError a)
queryExpr (forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall a b. (a -> b) -> a -> b
$ forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall era. QueryInShelleyBasedEra era (Set PoolId)
QueryStakePools))
          forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnsupportedNtcVersionError -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedNtcVersion)
          forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraMismatch -> ShelleyQueryCmdError
ShelleyQueryCmdEraMismatch)
    ) forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)
      forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left

  Maybe OutputFile
-> Set PoolId -> ExceptT ShelleyQueryCmdError IO ()
writeStakePools Maybe OutputFile
mOutFile Set PoolId
poolIds

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

writeStakePools Maybe OutputFile
Nothing Set PoolId
stakePools =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Set a -> [a]
Set.toList Set PoolId
stakePools) forall a b. (a -> b) -> a -> b
$ \PoolId
poolId ->
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ Text -> [Char]
Text.unpack (forall a. SerialiseAsBech32 a => a -> Text
serialiseToBech32 PoolId
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 [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> IO (Either AcquiringFailure AnyCardanoEra)
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)

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

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

  let query :: QueryInMode mode (Either EraMismatch (Map PoolId Rational))
query = forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall a b. (a -> b) -> a -> b
$ forall era. QueryInShelleyBasedEra era (Map PoolId Rational)
QueryStakeDistribution

  Map PoolId Rational
result <- 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 PoolId Rational))
query

  Maybe OutputFile
-> Map PoolId Rational -> ExceptT ShelleyQueryCmdError IO ()
writeStakeDistribution Maybe OutputFile
mOutFile Map PoolId Rational
result

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

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


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

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

-- | 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
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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [DelegationsAndRewards] -> ShowS
$cshowList :: [DelegationsAndRewards] -> ShowS
show :: DelegationsAndRewards -> [Char]
$cshow :: DelegationsAndRewards -> [Char]
showsPrec :: Int -> DelegationsAndRewards -> ShowS
$cshowsPrec :: Int -> DelegationsAndRewards -> ShowS
Show)


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


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

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

     decodeObject :: Aeson.Value
                  -> Aeson.Parser (StakeAddress, Maybe Lovelace, Maybe PoolId)
     decodeObject :: Value -> Parser (StakeAddress, Maybe Lovelace, Maybe PoolId)
decodeObject  = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"DelegationsAndRewards" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
       StakeAddress
address <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"address"
       Maybe PoolId
delegation <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"delegation"
       Maybe Lovelace
rewardAccountBalance <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"rewardAccountBalance"
       forall (f :: * -> *) a. Applicative f => a -> f a
pure (StakeAddress
address, Maybe Lovelace
rewardAccountBalance, Maybe PoolId
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 [Char]
genFile) VerificationKeyOrHashOrFile StakePoolKey
coldVerKeyFile (SigningKeyFile [Char]
vrfSkeyFp)
                           EpochLeadershipSchedule
whichSchedule Maybe OutputFile
mJsonOutputFile = do
  SocketPath [Char]
sockPath <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (Either EnvSocketError SocketPath)
readEnvSocketPath forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvSocketError -> ShelleyQueryCmdError
ShelleyQueryCmdEnvVarSocketErr)

  let localNodeConnInfo :: LocalNodeConnectInfo mode
localNodeConnInfo = forall mode.
ConsensusModeParams mode
-> NetworkId -> [Char] -> LocalNodeConnectInfo mode
LocalNodeConnectInfo ConsensusModeParams mode
cModeParams NetworkId
network [Char]
sockPath

  anyE :: AnyCardanoEra
anyE@(AnyCardanoEra CardanoEra era
era) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode.
ConsensusModeParams mode
-> LocalNodeConnectInfo mode
-> IO (Either AcquiringFailure AnyCardanoEra)
determineEra ConsensusModeParams mode
cModeParams LocalNodeConnectInfo mode
localNodeConnInfo)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)

  ShelleyBasedEra era
sbe <- forall (m :: * -> *) era.
Monad m =>
CardanoEraStyle era
-> ExceptT ShelleyQueryCmdError m (ShelleyBasedEra era)
getSbe (forall era. CardanoEra era -> CardanoEraStyle era
cardanoEraStyle CardanoEra era
era)

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

  PoolId
poolid <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall keyrole.
(Key keyrole, SerialiseAsBech32 (VerificationKey keyrole)) =>
AsType keyrole
-> VerificationKeyOrHashOrFile keyrole
-> IO (Either (FileError InputDecodeError) (Hash keyrole))
readVerificationKeyOrHashOrFile AsType StakePoolKey
AsStakePoolKey VerificationKeyOrHashOrFile StakePoolKey
coldVerKeyFile)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileError InputDecodeError -> ShelleyQueryCmdError
ShelleyQueryCmdTextReadError)

  SigningKey VrfKey
vrkSkey <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a.
HasTextEnvelope a =>
AsType a -> [Char] -> IO (Either (FileError TextEnvelopeError) a)
readFileTextEnvelope (forall a. AsType a -> AsType (SigningKey a)
AsSigningKey AsType VrfKey
AsVrfKey) [Char]
vrfSkeyFp)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileError TextEnvelopeError -> ShelleyQueryCmdError
ShelleyQueryCmdTextEnvelopeReadError)

  ShelleyGenesis StandardShelley
shelleyGenesis <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ([Char]
-> IO
     (Either ShelleyGenesisCmdError (ShelleyGenesis StandardShelley))
readAndDecodeShelleyGenesis [Char]
genFile)
    forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesisCmdError -> ShelleyQueryCmdError
ShelleyQueryCmdGenesisReadError)

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

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

      ProtocolParameters
pparams <- 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 <- 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall mode result.
LocalNodeConnectInfo mode
-> Maybe ChainPoint
-> QueryInMode mode result
-> IO (Either AcquiringFailure result)
queryNodeLocalState LocalNodeConnectInfo mode
localNodeConnInfo forall a. Maybe a
Nothing QueryInMode CardanoMode (EraHistory CardanoMode)
eraHistoryQuery)
        forall a b. a -> (a -> b) -> b
& forall e x (m :: * -> *) a.
Monad m =>
(e -> ExceptT x m a) -> ExceptT x m (Either e a) -> ExceptT x m a
onLeft (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AcquiringFailure -> ShelleyQueryCmdError
ShelleyQueryCmdAcquireFailure)

      let eInfo :: EpochInfo (Either Text)
eInfo = EraHistory CardanoMode -> EpochInfo (Either Text)
toEpochInfo EraHistory CardanoMode
eraHistory
      let currentEpochQuery :: QueryInMode mode (Either EraMismatch EpochNo)
currentEpochQuery = forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall a b. (a -> b) -> a -> b
$ forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall era. QueryInShelleyBasedEra era EpochNo
QueryEpoch
      EpochNo
curentEpoch <- 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

      let bpp :: BundledProtocolParameters era
bpp = forall era.
CardanoEra era
-> ProtocolParameters -> BundledProtocolParameters era
bundleProtocolParams CardanoEra era
era ProtocolParameters
pparams

      Set SlotNo
schedule <- case EpochLeadershipSchedule
whichSchedule of
        EpochLeadershipSchedule
CurrentEpoch -> do
          SerialisedPoolDistribution era
serCurrentEpochState <- 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 forall a b. (a -> b) -> a -> b
$
            forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall a b. (a -> b) -> a -> b
$ forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe (forall era.
Maybe (Set PoolId)
-> QueryInShelleyBasedEra era (SerialisedPoolDistribution era)
QueryPoolDistribution (forall a. a -> Maybe a
Just (forall a. a -> Set a
Set.singleton PoolId
poolid)))
          forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT LeadershipError -> ShelleyQueryCmdError
ShelleyQueryCmdLeaderShipError forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither
            forall a b. (a -> b) -> a -> b
$ 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,
     HashAnnotated
       (TxBody (ShelleyLedgerEra era))
       EraIndependentTxBody
       StandardCrypto) =>
    a)
-> a
eligibleLeaderSlotsConstaints ShelleyBasedEra era
sbe
            forall a b. (a -> b) -> a -> b
$ forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera, Era ledgerera,
 PraosProtocolSupportsNode (ConsensusProtocol era),
 HasField "_d" (PParams ledgerera) UnitInterval,
 FromCBOR (ChainDepState (ConsensusProtocol era))) =>
ShelleyBasedEra era
-> ShelleyGenesis StandardShelley
-> EpochInfo (Either Text)
-> BundledProtocolParameters era
-> ProtocolState era
-> PoolId
-> SigningKey VrfKey
-> SerialisedPoolDistribution era
-> EpochNo
-> Either LeadershipError (Set SlotNo)
currentEpochEligibleLeadershipSlots
              ShelleyBasedEra era
sbe
              ShelleyGenesis StandardShelley
shelleyGenesis
              EpochInfo (Either Text)
eInfo
              BundledProtocolParameters era
bpp
              ProtocolState era
ptclState
              PoolId
poolid
              SigningKey VrfKey
vrkSkey
              SerialisedPoolDistribution era
serCurrentEpochState
              EpochNo
curentEpoch

        EpochLeadershipSchedule
NextEpoch -> do
          let currentEpochStateQuery :: QueryInMode
  mode (Either EraMismatch (SerialisedCurrentEpochState era))
currentEpochStateQuery = forall era mode result1.
EraInMode era mode
-> QueryInEra era result1
-> QueryInMode mode (Either EraMismatch result1)
QueryInEra EraInMode era mode
eInMode forall a b. (a -> b) -> a -> b
$ forall era result.
ShelleyBasedEra era
-> QueryInShelleyBasedEra era result -> QueryInEra era result
QueryInShelleyBasedEra ShelleyBasedEra era
sbe forall era.
QueryInShelleyBasedEra era (SerialisedCurrentEpochState era)
QueryCurrentEpochState

          ChainTip
tip <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall mode. LocalNodeConnectInfo mode -> IO ChainTip
getLocalChainTip LocalNodeConnectInfo mode
localNodeConnInfo
          SerialisedCurrentEpochState era
serCurrentEpochState <- 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

          forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT LeadershipError -> ShelleyQueryCmdError
ShelleyQueryCmdLeaderShipError forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither
            forall a b. (a -> b) -> a -> b
$ 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,
     HashAnnotated
       (TxBody (ShelleyLedgerEra era))
       EraIndependentTxBody
       StandardCrypto) =>
    a)
-> a
eligibleLeaderSlotsConstaints ShelleyBasedEra era
sbe
            forall a b. (a -> b) -> a -> b
$ forall era.
(HasField "_d" (PParams (ShelleyLedgerEra era)) UnitInterval,
 HashAnnotated
   (TxBody (ShelleyLedgerEra era))
   EraIndependentTxBody
   (Crypto (ShelleyLedgerEra era)),
 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
-> PoolId
-> SigningKey VrfKey
-> BundledProtocolParameters era
-> EpochInfo (Either Text)
-> (ChainTip, EpochNo)
-> Either LeadershipError (Set SlotNo)
nextEpochEligibleLeadershipSlots ShelleyBasedEra era
sbe ShelleyGenesis StandardShelley
shelleyGenesis
              SerialisedCurrentEpochState era
serCurrentEpochState ProtocolState era
ptclState PoolId
poolid SigningKey VrfKey
vrkSkey BundledProtocolParameters era
bpp
              EpochInfo (Either Text)
eInfo (ChainTip
tip, EpochNo
curentEpoch)

      case Maybe OutputFile
mJsonOutputFile of
        Maybe OutputFile
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall a b. (a -> b) -> a -> b
$ forall era. ShelleyGenesis era -> UTCTime
sgSystemStart ShelleyGenesis StandardShelley
shelleyGenesis)
        Just (OutputFile [Char]
jsonOutputFile) ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
LBS.writeFile [Char]
jsonOutputFile 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 forall a b. (a -> b) -> a -> b
$ forall era. ShelleyGenesis era -> UTCTime
sgSystemStart ShelleyGenesis StandardShelley
shelleyGenesis)
    ConsensusMode mode
mode -> forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyConsensusMode -> ShelleyQueryCmdError
ShelleyQueryCmdUnsupportedMode forall a b. (a -> b) -> a -> b
$ 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
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate (Text -> Int
Text.length Text
title forall a. Num a => a -> a -> a
+ Int
2) Char
'-'
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ SlotNo -> EpochInfo (Either Text) -> SystemStart -> [Char]
showLeadershipSlot SlotNo
slot EpochInfo (Either Text)
eInfo SystemStart
sStart
      | SlotNo
slot <- 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 -> [Char]
showLeadershipSlot lSlot :: SlotNo
lSlot@(SlotNo Word64
sn) EpochInfo (Either Text)
eInfo' SystemStart
sStart' =
       case forall (m :: * -> *).
(HasCallStack, Monad m) =>
EpochInfo m -> SystemStart -> SlotNo -> m UTCTime
epochInfoSlotToUTCTime EpochInfo (Either Text)
eInfo' SystemStart
sStart' SlotNo
lSlot of
         Right UTCTime
slotTime ->
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
           [ [Char]
"     "
           , forall a. Show a => a -> [Char]
show Word64
sn
           , [Char]
"                   "
           , forall a. Show a => a -> [Char]
show UTCTime
slotTime
           ]
         Left Text
err ->
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
           [ [Char]
"     "
           , forall a. Show a => a -> [Char]
show Word64
sn
           , [Char]
"                   "
           , Text -> [Char]
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 =
    forall a. ToJSON a => a -> ByteString
encodePretty forall a b. (a -> b) -> a -> b
$ SlotNo -> Value
showLeadershipSlot forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => [a] -> [a]
List.sort (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 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
Aeson..= Word64
sn
              , Key
"slotTime" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
Aeson..= UTCTime
slotTime
              ]
          Left Text
err ->
            [Pair] -> Value
Aeson.object
              [ Key
"slotNumber" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
Aeson..= Word64
sn
              , Key
"error" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
Aeson..= Text -> [Char]
Text.unpack Text
err
              ]


-- Helpers

calcEraInMode
  :: CardanoEra era
  -> ConsensusMode mode
  -> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
calcEraInMode :: forall era mode.
CardanoEra era
-> ConsensusMode mode
-> ExceptT ShelleyQueryCmdError IO (EraInMode era mode)
calcEraInMode CardanoEra era
era ConsensusMode mode
mode =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era mode.
CardanoEra era -> ConsensusMode mode -> Maybe (EraInMode era mode)
toEraInMode CardanoEra era
era ConsensusMode mode
mode)
    forall a b. a -> (a -> b) -> b
& forall x (m :: * -> *) a.
Monad m =>
ExceptT x m a -> ExceptT x m (Maybe a) -> ExceptT x m a
onNothing (forall (m :: * -> *) x a. Monad m => x -> ExceptT x m a
left (AnyConsensusMode -> AnyCardanoEra -> ShelleyQueryCmdError
ShelleyQueryCmdEraConsensusModeMismatch (forall mode. ConsensusMode mode -> AnyConsensusMode
AnyConsensusMode