wip: cardano-api with kes-agent support

Author: fraser-iohk

cabal.project

@@ -14,7 +14,7 @@ repository cardano-haskell-packages
 -- you need to run if you change them
 index-state:
   , hackage.haskell.org 2025-06-22T20:18:27Z
-  , cardano-haskell-packages 2025-06-20T09:11:51Z
+  , cardano-haskell-packages 2025-07-22T10:42:20Z
 
 packages:
     cardano-api
@@ -61,6 +61,7 @@ if impl (ghc >= 9.12)
     -- https://github.com/kapralVV/Unique/issues/11
     , Unique:hashable
 
+
 -- WASM compilation specific
 
 if arch(wasm32)
@@ -156,3 +157,76 @@ if arch(wasm32)
 -- Do NOT add more source-repository-package stanzas here unless they are strictly
 -- temporary! Please read the section in CONTRIBUTING about updating dependencies.
 
+allow-newer:
+  , cardano-ledger-core
+  , cardano-ledger-byron
+  , serdoc-core:tasty-quickcheck
+
+  , kes-agent:containers
+  -- , hedgehog-quickcheck:QuickCheck
+  , *:QuickCheck
+
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/kes-agent
+  tag: 60acf5d1c949695dc7822945b18fc916e7ef4391
+  --sha256: sha256-oTsxaFAs1c/H0oYLhiivO5mr48oHNsPi5k2XyXxwCJg=
+  subdir:
+      kes-agent
+
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/ouroboros-network
+  tag: 253316ae1c5ec0eaf79f306eac1986969b7842a4
+  --sha256: sha256-0HZ49kIgCrv/H9I/aUb+wFfRiVuZMrUofJFdgWPG17o=
+  subdir: ouroboros-network-api
+          ouroboros-network
+          ouroboros-network-framework
+          ouroboros-network-protocols
+
+source-repository-package
+   type: git
+   location: https://github.com/IntersectMBO/cardano-ledger
+   tag: ca8d451bbce11dde3b68e99782c79f9b4c1dfca5
+   --sha256: sha256-YHIscWnp9GrFn0EYGM7xd8Ds8x0O00FWBAIZX22bWpA=
+   subdir:
+      eras/allegra/impl
+      eras/alonzo/impl
+      eras/alonzo/test-suite
+      eras/babbage/impl
+      eras/babbage/test-suite
+      eras/byron/chain/executable-spec
+      eras/byron/crypto
+      eras/byron/ledger/executable-spec
+      eras/byron/ledger/impl
+      eras/conway/impl
+      eras/conway/test-suite
+      eras/dijkstra/
+      eras/mary/impl
+      eras/shelley/impl
+      eras/shelley-ma/test-suite
+      eras/shelley/test-suite
+      libs/cardano-data
+      libs/cardano-ledger-api
+      libs/cardano-ledger-binary
+      libs/cardano-ledger-core
+      libs/cardano-ledger-test
+      libs/cardano-protocol-tpraos
+      libs/constrained-generators
+      libs/non-integral
+      libs/set-algebra
+      libs/small-steps
+      libs/vector-map
+
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/ouroboros-consensus
+  tag: 26c831eb40bd15750ef8243285466fe9bd582cf7
+  --sha256: sha256-oTsxaFAs1c/H0oYLhiivO5mr48oHNsPi5k2XyXxwCJg=
+  subdir:
+      ouroboros-consensus
+      ouroboros-consensus-cardano
+      ouroboros-consensus-diffusion
+      ouroboros-consensus-protocol
+      sop-extras
+      strict-sop-core

cardano-api/cardano-api.cabal

@@ -130,7 +130,7 @@ library
     cardano-ledger-binary >=1.6,
     cardano-ledger-byron >=1.1,
     cardano-ledger-conway >=1.19,
-    cardano-ledger-core:{cardano-ledger-core, testlib} >=1.17,
+    cardano-ledger-core:{cardano-ledger-core, testlib} >=1.17 && <1.19,
     cardano-ledger-mary >=1.8,
     cardano-ledger-shelley >=1.16,
     cardano-protocol-tpraos >=1.4,
@@ -164,11 +164,11 @@ library
     ouroboros-consensus-diffusion ^>=0.23,
     ouroboros-consensus-protocol ^>=0.12,
     ouroboros-network,
-    ouroboros-network-api >=0.14,
+    ouroboros-network-api >=0.15,
     ouroboros-network-framework,
-    ouroboros-network-protocols >=0.14,
+    ouroboros-network-protocols >=0.15,
     parsec,
-    plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib} ^>=1.45,
+    plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib} ^>=1.50,
     pretty-simple,
     prettyprinter,
     prettyprinter-ansi-terminal,
@@ -186,7 +186,7 @@ library
     time,
     transformers,
     transformers-except ^>=0.1.3,
-    typed-protocols ^>=0.3,
+    typed-protocols ^>=1.0,
     vector,
     yaml,
 
@@ -428,7 +428,7 @@ test-suite cardano-api-golden
     hedgehog >=1.1,
     hedgehog-extras ^>=0.8,
     microlens,
-    plutus-core ^>=1.45,
+    plutus-core ^>=1.50,
     plutus-ledger-api,
     tasty,
     tasty-discover,

cardano-api/src/Cardano/Api/Block.hs

@@ -72,7 +72,6 @@ import Ouroboros.Consensus.Byron.Ledger qualified as Consensus
 import Ouroboros.Consensus.Cardano.Block qualified as Consensus
 import Ouroboros.Consensus.HardFork.Combinator qualified as Consensus
 import Ouroboros.Consensus.Shelley.Ledger qualified as Consensus
-import Ouroboros.Consensus.Shelley.Protocol.Abstract qualified as Consensus
 import Ouroboros.Network.Block qualified as Consensus
 
 import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.=))
@@ -167,7 +166,6 @@ getShelleyBlockTxs
   :: forall era ledgerera blockheader
    . ShelleyLedgerEra era ~ ledgerera
   => Consensus.ShelleyCompatible (ConsensusProtocol era) ledgerera
-  => Consensus.ShelleyProtocolHeader (ConsensusProtocol era) ~ blockheader
   => ShelleyBasedEra era
   -> Ledger.Block blockheader ledgerera
   -> [Tx era]
@@ -203,6 +201,7 @@ fromConsensusBlock = \case
   Consensus.BlockAlonzo b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraAlonzo b'
   Consensus.BlockBabbage b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraBabbage b'
   Consensus.BlockConway b' -> BlockInMode cardanoEra $ ShelleyBlock ShelleyBasedEraConway b'
+  _ -> undefined
 
 toConsensusBlock
   :: ()

cardano-api/src/Cardano/Api/Certificate/Internal.hs

@@ -576,6 +576,7 @@ filterUnRegCreds =
         Ledger.RetirePoolTxCert _ _ -> Nothing
         Ledger.MirTxCert _ -> Nothing
         Ledger.GenesisDelegTxCert{} -> Nothing
+        _ -> undefined
     ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $
       case conwayCert of
         Ledger.RegPoolTxCert _ -> Nothing
@@ -593,6 +594,7 @@ filterUnRegCreds =
         Ledger.RegTxCert _ -> Nothing
         -- stake cred deregistration w/o deposit
         Ledger.UnRegTxCert cred -> Just cred
+        _ -> undefined
 
 filterUnRegDRepCreds
   :: Certificate era -> Maybe (Ledger.Credential Ledger.DRepRole)
@@ -615,6 +617,7 @@ filterUnRegDRepCreds = \case
       Ledger.RegTxCert _ -> Nothing
       -- stake cred deregistration w/o deposit
       Ledger.UnRegTxCert _ -> Nothing
+      _ -> undefined
 
 -- ----------------------------------------------------------------------------
 -- Internal conversion functions
@@ -803,6 +806,7 @@ getAnchorDataFromCertificate c =
           Ledger.RetirePoolTxCert _ _ -> return Nothing
           Ledger.GenesisDelegTxCert{} -> return Nothing
           Ledger.MirTxCert _ -> return Nothing
+          _ -> undefined
     ConwayCertificate ceo ccert ->
       conwayEraOnwardsConstraints ceo $
         case ccert of
@@ -819,6 +823,7 @@ getAnchorDataFromCertificate c =
           Ledger.UpdateDRepTxCert _ mAnchor -> return $ Ledger.strictMaybeToMaybe mAnchor
           Ledger.AuthCommitteeHotKeyTxCert _ _ -> return Nothing
           Ledger.ResignCommitteeColdTxCert _ mAnchor -> return $ Ledger.strictMaybeToMaybe mAnchor
+          _ -> undefined
  where
   anchorDataFromPoolMetadata
     :: MonadError AnchorDataFromCertificateError m

cardano-api/src/Cardano/Api/Consensus/Internal/InMode.hs

@@ -100,6 +100,7 @@ fromConsensusGenTx = \case
   Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (Z tx')))))))) ->
     let Consensus.ShelleyTx _txid shelleyEraTx = tx'
      in TxInMode ShelleyBasedEraConway (ShelleyTx ShelleyBasedEraConway shelleyEraTx)
+  _ -> undefined
 
 toConsensusGenTx
   :: ()
@@ -302,3 +303,4 @@ fromConsensusApplyTxErr = \case
     TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraConway err
   Consensus.ApplyTxErrWrongEra err ->
     TxValidationEraMismatch err
+  _ -> undefined

cardano-api/src/Cardano/Api/Consensus/Internal/Mode.hs

@@ -161,3 +161,5 @@ fromConsensusEraIndex = \case
     AnyCardanoEra BabbageEra
   Consensus.EraIndex (S (S (S (S (S (S (Z (K ())))))))) ->
     AnyCardanoEra ConwayEra
+  Consensus.EraIndex (S (S (S (S (S (S (S (Z (K ()))))))))) ->
+    AnyCardanoEra ConwayEra

cardano-api/src/Cardano/Api/Consensus/Internal/Protocol.hs

@@ -22,6 +22,7 @@ where
 
 import Cardano.Api.Consensus.Internal.Mode
 
+import qualified Control.Tracer as Tracer
 import Ouroboros.Consensus.Block.Forging (BlockForging)
 import Ouroboros.Consensus.Byron.ByronHFC (ByronBlockHFC)
 import Ouroboros.Consensus.Cardano
@@ -31,6 +32,7 @@ import Ouroboros.Consensus.HardFork.Combinator.Embed.Unary
 import Ouroboros.Consensus.Ledger.SupportsProtocol qualified as Consensus (LedgerSupportsProtocol)
 import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolClientInfo (..), ProtocolInfo (..))
 import Ouroboros.Consensus.Node.Run (RunNode)
+import Ouroboros.Consensus.Protocol.Praos.AgentClient
 import Ouroboros.Consensus.Protocol.TPraos qualified as Consensus
 import Ouroboros.Consensus.Shelley.Eras qualified as Consensus (ShelleyEra)
 import Ouroboros.Consensus.Shelley.Ledger.Block qualified as Consensus (ShelleyBlock)
@@ -44,7 +46,11 @@ import Type.Reflection ((:~:) (..))
 
 class (RunNode blk, IOLike m) => Protocol m blk where
   data ProtocolInfoArgs blk
-  protocolInfo :: ProtocolInfoArgs blk -> (ProtocolInfo blk, m [BlockForging m blk])
+  protocolInfo
+    :: ProtocolInfoArgs blk
+    -> ( ProtocolInfo blk
+       , Tracer.Tracer m KESAgentClientTrace -> m [BlockForging m blk]
+       )
 
 -- | Node client support for each consensus protocol.
 --
@@ -59,10 +65,10 @@ instance IOLike m => Protocol m ByronBlockHFC where
   data ProtocolInfoArgs ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron
   protocolInfo (ProtocolInfoArgsByron params) =
     ( inject $ protocolInfoByron params
-    , pure . map inject $ blockForgingByron params
+    , \_ -> pure . map inject $ blockForgingByron params
     )
 
-instance (CardanoHardForkConstraints StandardCrypto, IOLike m) => Protocol m (CardanoBlock StandardCrypto) where
+instance (CardanoHardForkConstraints StandardCrypto, IOLike m, MonadKESAgent m) => Protocol m (CardanoBlock StandardCrypto) where
   data ProtocolInfoArgs (CardanoBlock StandardCrypto)
     = ProtocolInfoArgsCardano
         (CardanoProtocolParams StandardCrypto)
@@ -89,6 +95,7 @@ instance
           (Consensus.TPraos StandardCrypto)
           ShelleyEra
       )
+  , MonadKESAgent m
   )
   => Protocol m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra)
   where
@@ -98,7 +105,7 @@ instance
         (ProtocolParamsShelleyBased StandardCrypto)
         ProtVer
   protocolInfo (ProtocolInfoArgsShelley genesis paramsShelleyBased_ paramsShelley_) =
-    bimap inject (fmap $ map inject) $
+    bimap inject (fmap $ fmap $ map inject) $
       protocolInfoShelley genesis paramsShelleyBased_ paramsShelley_
 
 instance

cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs

@@ -74,6 +74,7 @@ getPlutusScriptWitnessLanguage (PlutusScriptWitness l _ _ _ _) =
     L.SPlutusV1 -> L.plutusLanguage l
     L.SPlutusV2 -> L.plutusLanguage l
     L.SPlutusV3 -> L.plutusLanguage l
+    _ -> undefined
 
 -- | Every Plutus script has a purpose that indicates
 -- what that script is witnessing.

cardano-api/src/Cardano/Api/Experimental/Tx.hs

@@ -167,7 +167,6 @@ import Cardano.Crypto.Hash qualified as Hash
 import Cardano.Ledger.Alonzo.TxBody qualified as L
 import Cardano.Ledger.Api qualified as L
 import Cardano.Ledger.Binary qualified as Ledger
-import Cardano.Ledger.Conway.TxBody qualified as L
 import Cardano.Ledger.Core qualified as Ledger
 import Cardano.Ledger.Hashes qualified as L hiding (Hash)
 

cardano-api/src/Cardano/Api/Experimental/Tx/Internal/AnyWitness.hs

@@ -143,6 +143,7 @@ fromPlutusRunnable L.SPlutusV3 eon runnable =
     AlonzoEraOnwardsConway ->
       let plutusScript = L.plutusFromRunnable runnable
        in Just $ L.ConwayPlutusV3 plutusScript
+fromPlutusRunnable _ _ _ = undefined
 
 toAlonzoDatum
   :: AlonzoEraOnwards era
@@ -162,3 +163,5 @@ getPlutusDatum L.SPlutusV2 (SpendingScriptDatum d) = Just d
 getPlutusDatum L.SPlutusV3 (SpendingScriptDatum d) = d
 getPlutusDatum _ InlineDatum = Nothing
 getPlutusDatum _ NoScriptDatum = Nothing
+getPlutusDatum _ _ = undefined
+