{-# 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)
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
| 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)
percentage
:: RelativeTime
-> RelativeTime
-> RelativeTime
-> 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
t :: Integer
t = RelativeTime -> Integer
relativeTimeSeconds RelativeTime
tolerance
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
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
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)
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)
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))
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)
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
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
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
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
}
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)
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
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
]
)
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
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
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
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
data ShelleyQueryCmdLocalStateQueryError
= AcquireFailureError !LocalStateQuery.AcquireFailure
| EraMismatchError !EraMismatch
| ByronProtocolNotSupportedError
| ShelleyProtocolEraMismatch
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)
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
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
-> 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]
""
]
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
-> VerificationKeyOrHashOrFile StakePoolKey
-> SigningKeyFile
-> 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
]
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