Fix reading pool state for new ledger version, add dijkstra script purposes to ToJSON instances

Author: carbolymer

cardano-cli/src/Cardano/CLI/Compatible/Json/Friendly.hs

@@ -274,6 +274,7 @@ data EraIndependentPlutusScriptPurpose
   | Rewarding
   | Voting
   | Proposing
+  | Guarding
 
 getScriptWitnessDetails
   :: forall era. Exp.Era era -> TxBody era -> [Aeson.Pair]
@@ -345,29 +346,35 @@ getScriptWitnessDetails era tb =
       Ledger.ConwayRewarding (L.AsIxItem _ rp) -> addLabelToPurpose Rewarding rp
       Ledger.ConwayVoting (L.AsIxItem _ vp) -> addLabelToPurpose Voting vp
       Ledger.ConwayProposing (L.AsIxItem _ pp) -> addLabelToPurpose Proposing pp
-  friendlyPurpose AlonzoEraOnwardsDijkstra purpose =
-    alonzoEraOnwardsConstraints AlonzoEraOnwardsDijkstra $
-      error "TODO Dijkstra"
-  -- case purpose of
-  --   Ledger.ConwaySpending (L.AsIxItem _ sp) -> addLabelToPurpose Spending (friendlyInput sp)
-  --   Ledger.ConwayMinting (L.AsIxItem _ mp) -> addLabelToPurpose Minting mp
-  --   Ledger.ConwayCertifying (L.AsIxItem _ cp) -> addLabelToPurpose Certifying cp
-  --   Ledger.ConwayRewarding (L.AsIxItem _ rp) -> addLabelToPurpose Rewarding rp
-  --   Ledger.ConwayVoting (L.AsIxItem _ vp) -> addLabelToPurpose Voting vp
-  --   Ledger.ConwayProposing (L.AsIxItem _ pp) -> addLabelToPurpose Proposing pp
+  friendlyPurpose AlonzoEraOnwardsDijkstra purpose = do
+    let era' = fromJust $ forEraMaybeEon (convert era)
+    obtainCommonConstraints era' $
+      case purpose of
+        Ledger.DijkstraSpending (L.AsIxItem _ sp) -> addLabelToPurpose Spending (friendlyInput sp)
+        Ledger.DijkstraMinting (L.AsIxItem _ mp) -> addLabelToPurpose Minting mp
+        Ledger.DijkstraCertifying (L.AsIxItem _ cp) -> addLabelToPurpose Certifying cp
+        Ledger.DijkstraRewarding (L.AsIxItem _ rp) -> addLabelToPurpose Rewarding rp
+        Ledger.DijkstraVoting (L.AsIxItem _ vp) -> addLabelToPurpose Voting vp
+        Ledger.DijkstraProposing (L.AsIxItem _ pp) -> addLabelToPurpose Proposing pp
+        Ledger.DijkstraGuarding (L.AsIxItem _ pp) -> addLabelToPurpose Guarding pp
   friendlyInput :: Ledger.TxIn -> Aeson.Value
   friendlyInput (Ledger.TxIn (Ledger.TxId txidHash) ix) =
     Aeson.String $
       T.pack $
         T.unpack (hashToTextAsHex (extractHash txidHash)) ++ "#" ++ show (Ledger.txIxToInt ix)
 
-  addLabelToPurpose :: ToJSON v => EraIndependentPlutusScriptPurpose -> v -> Aeson.Value
+  addLabelToPurpose
+    :: ToJSON v
+    => EraIndependentPlutusScriptPurpose
+    -> v
+    -> Aeson.Value
   addLabelToPurpose Spending sp = Aeson.object ["spending script witnessed input" .= sp]
   addLabelToPurpose Minting mp = Aeson.object ["minting currency with policy id" .= mp]
   addLabelToPurpose Certifying cp = Aeson.object ["validating certificate with script credentials" .= cp]
   addLabelToPurpose Rewarding rp = Aeson.object ["withdrawing reward from script address" .= rp]
   addLabelToPurpose Voting vp = Aeson.object ["voting using script protected voter credentials" .= vp]
   addLabelToPurpose Proposing pp = Aeson.object ["submitting a proposal following proposal policy" .= pp]
+  addLabelToPurpose Guarding _ = error "TODO Dijkstra"
 
   friendlyScriptData :: Ledger.Tx (ShelleyLedgerEra era) -> Aeson.Value
   friendlyScriptData tx =
@@ -651,7 +658,7 @@ renderCertificate sbe = \case
               [ "pot" .= friendlyMirPot pot
               , friendlyMirTarget sbe target
               ]
-  ConwayCertificate w cert ->
+  ConwayCertificate w@ConwayEraOnwardsConway (cert :: L.ConwayTxCert (ShelleyLedgerEra ConwayEra)) ->
     conwayEraOnwardsConstraints w $
       case cert of
         L.RegDRepTxCert credential coin mAnchor ->
@@ -747,9 +754,10 @@ renderCertificate sbe = \case
               [ "Drep credential" .= drepCredential
               , "anchor " .= mbAnchor
               ]
-        -- TODO: Dijkstra
-        -- Pattern is complete for Conway, we're missing COMPLETE pragma for Dijkstra in ledger to remove this error
-        _ -> error "renderCertificate: Dijkstra"
+        -- TODO Dijkstra: What's missing here?
+        _ -> error "renderCertificate: TODO Dijkstra impossible"
+  ConwayCertificate ConwayEraOnwardsDijkstra _ ->
+    error "renderCertificate: TODO Dijkstra era not supported"
  where
   conwayToObject
     :: ()

cardano-cli/src/Cardano/CLI/EraBased/Query/Run.hs

@@ -658,7 +658,7 @@ runQueryPoolStateCmd
                 Only poolIds -> Just $ fromList poolIds
 
           result <- easyRunQuery (queryPoolState beo poolFilter)
-          hoist liftIO $ obtainCommonConstraints era (writePoolState outputFormat) mOutFile result
+          hoist liftIO $ writePoolState era outputFormat mOutFile result
       )
       & fromEitherCIOCli
 
@@ -1183,38 +1183,18 @@ writeStakeSnapshots outputFormat mOutFile qState = do
 -- | This function obtains the pool parameters, equivalent to the following jq query on the output of query ledger-state
 --   .nesEs.esLState.lsDPState.dpsPState.psStakePoolParams.<pool_id>
 writePoolState
-  :: Vary [FormatJson, FormatYaml]
+  :: Exp.Era era
+  -> Vary [FormatJson, FormatYaml]
   -> Maybe (File () Out)
   -> SerialisedPoolState
   -> ExceptT QueryCmdError IO ()
-writePoolState outputFormat mOutFile serialisedCurrentEpochState = do
-  -- PoolState poolState <-
-  --   pure (decodePoolState serialisedCurrentEpochState)
-  --     & onLeft (left . QueryCmdPoolStateDecodeError)
-  let poolState = error "TODO Dijkstra"
-
-  let hks :: [L.KeyHash L.StakePool]
-      hks =
-        toList $
-          Map.keysSet (L.psStakePools poolState)
-            <> Map.keysSet (L.psFutureStakePools poolState)
-            <> Map.keysSet (L.psRetiring poolState)
-
-  let poolStates :: Map (L.KeyHash 'L.StakePool) Params
-      poolStates =
-        fromList $
-          hks
-            <&> ( \hk ->
-                    ( hk
-                    , Params
-                        { poolParameters = Map.lookup hk (L.psStakePools poolState)
-                        , futurePoolParameters = Map.lookup hk (L.psFutureStakePools poolState)
-                        , retiringEpoch = Map.lookup hk (L.psRetiring poolState)
-                        }
-                    )
-                )
+writePoolState era outputFormat mOutFile serialisedCurrentEpochState = do
+  poolState <-
+    liftEither . first QueryCmdPoolStateDecodeError $
+      decodePoolState (convert era) serialisedCurrentEpochState
 
-  let output =
+  let poolStates = mkPoolStates poolState :: Map (L.KeyHash L.StakePool) PoolParams
+      output =
         outputFormat
           & ( id
                 . Vary.on (\FormatJson -> Json.encodeJson)
@@ -1823,22 +1803,17 @@ runQuerySPOStakeDistribution
 
     let poolIds :: Set (Hash StakePoolKey) = Set.fromList $ map StakePoolKeyHash $ Map.keys spoStakeDistribution
 
-    serialisedPoolState :: SerialisedPoolState <-
+    serialisedPoolState <-
       fromExceptTCli $ runQuery nodeConnInfo target $ queryPoolState beo (Just poolIds)
 
-    -- PoolState (poolState :: L.PState (ShelleyLedgerEra era)) <-
-    --   fromEitherCli $ decodePoolState (convert eon) serialisedPoolState
-    let poolState = error "TODO Dijkstra"
+    PoolState poolStateResult <-
+      fromEitherCli $ decodePoolState (convert eon) serialisedPoolState
 
     let spoToRewardCred :: Map (L.KeyHash L.StakePool) (L.Credential 'L.Staking)
         spoToRewardCred =
-          Map.mapWithKey
-            ( \k ->
-                L.raCredential
-                  . L.ppRewardAccount
-                  . L.stakePoolStateToPoolParams k
-            )
-            (L.psStakePools poolState)
+          Map.map
+            (L.raCredential . L.ppRewardAccount)
+            (L.qpsrStakePoolParams poolStateResult)
 
         allRewardCreds :: Set StakeCredential
         allRewardCreds = Set.fromList $ map fromShelleyStakeCredential $ Map.elems spoToRewardCred

cardano-cli/src/Cardano/CLI/Type/Common.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 
 module Cardano.CLI.Type.Common
@@ -50,7 +51,8 @@ module Cardano.CLI.Type.Common
   , OpCertNodeStateCounter (..)
   , OpCertOnDiskCounter (..)
   , OpCertStartingKesPeriod (..)
-  , Params (..)
+  , PoolParams (..)
+  , mkPoolStates
   , ParserFileDirection (..)
   , PrivKeyFile (..)
   , ProposalBinary
@@ -102,10 +104,15 @@ where
 
 import Cardano.Api hiding (Script)
 import Cardano.Api.Ledger qualified as L
+
+import Cardano.Ledger.Api.State.Query qualified as L
+import Cardano.Ledger.Compactible qualified as L
 import Cardano.Ledger.State qualified as L
 
 import Data.Aeson (object, pairs, (.=))
 import Data.Aeson qualified as Aeson
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
 import Data.String (IsString)
 import Data.Text (Text)
 import Data.Text qualified as Text
@@ -348,23 +355,43 @@ data AllOrOnly a = All | Only [a] deriving (Eq, Show)
 -- | This data structure is used to allow nicely formatted output in the query pool-params command.
 -- params are the current pool parameter settings, futureparams are new parameters, retiringEpoch is the
 -- epoch that has been set for pool retirement.  Any of these may be Nothing.
-data Params = Params
+data PoolParams = PoolParams
   { poolParameters :: Maybe L.StakePoolState
   , futurePoolParameters :: Maybe L.StakePoolState
   , retiringEpoch :: Maybe EpochNo
   }
   deriving Show
 
+mkPoolStates :: PoolState era -> Map (L.KeyHash L.StakePool) PoolParams
+mkPoolStates
+  ( PoolState
+      ( L.QueryPoolStateResult
+          { L.qpsrStakePoolParams
+          , L.qpsrFutureStakePoolParams
+          , L.qpsrRetiring
+          , L.qpsrDeposits
+          }
+        )
+    ) = (`Map.mapWithKey` qpsrStakePoolParams) $ \kh pp -> do
+    let mDeposit = L.toCompact =<< Map.lookup kh qpsrDeposits
+    PoolParams
+      { poolParameters = (`L.mkStakePoolState` pp) <$> mDeposit
+      , futurePoolParameters = do
+          futurePp <- Map.lookup kh qpsrFutureStakePoolParams
+          (`L.mkStakePoolState` futurePp) <$> mDeposit
+      , retiringEpoch = Map.lookup kh qpsrRetiring
+      }
+
 -- | Pretty printing for pool parameters
-instance ToJSON Params where
-  toJSON (Params p fp r) =
+instance ToJSON PoolParams where
+  toJSON (PoolParams p fp r) =
     object
       [ "poolParams" .= p
       , "futurePoolParams" .= fp
       , "retiring" .= r
       ]
 
-  toEncoding (Params p fp r) =
+  toEncoding (PoolParams p fp r) =
     pairs $
       mconcat
         [ "poolParams" .= p