WIP

Author: Jimbo4350

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

@@ -234,6 +234,7 @@ certificateToTxCert c =
     ConwayCertificate eon cert ->
       case eon of
         ConwayEraOnwardsConway -> cert
+        ConwayEraOnwardsDijkstra -> cert
 
 -- ----------------------------------------------------------------------------
 -- Stake pool parameters
@@ -576,6 +577,7 @@ filterUnRegCreds =
         Ledger.RetirePoolTxCert _ _ -> Nothing
         Ledger.MirTxCert _ -> Nothing
         Ledger.GenesisDelegTxCert{} -> Nothing
+        _ -> error "dijkstra"
     ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $
       case conwayCert of
         Ledger.RegPoolTxCert _ -> Nothing
@@ -593,6 +595,7 @@ filterUnRegCreds =
         Ledger.RegTxCert _ -> Nothing
         -- stake cred deregistration w/o deposit
         Ledger.UnRegTxCert cred -> Just cred
+        _ -> error "dijkstra"
 
 filterUnRegDRepCreds
   :: Certificate era -> Maybe (Ledger.Credential Ledger.DRepRole)
@@ -615,6 +618,7 @@ filterUnRegDRepCreds = \case
       Ledger.RegTxCert _ -> Nothing
       -- stake cred deregistration w/o deposit
       Ledger.UnRegTxCert _ -> Nothing
+      _ -> error "dijkstra"
 
 -- ----------------------------------------------------------------------------
 -- Internal conversion functions
@@ -803,6 +807,7 @@ getAnchorDataFromCertificate c =
           Ledger.RetirePoolTxCert _ _ -> return Nothing
           Ledger.GenesisDelegTxCert{} -> return Nothing
           Ledger.MirTxCert _ -> return Nothing
+          _ -> error "dijkstra"
     ConwayCertificate ceo ccert ->
       conwayEraOnwardsConstraints ceo $
         case ccert of
@@ -819,6 +824,7 @@ getAnchorDataFromCertificate c =
           Ledger.UpdateDRepTxCert _ mAnchor -> return $ Ledger.strictMaybeToMaybe mAnchor
           Ledger.AuthCommitteeHotKeyTxCert _ _ -> return Nothing
           Ledger.ResignCommitteeColdTxCert _ mAnchor -> return $ Ledger.strictMaybeToMaybe mAnchor
+          _ -> error "dijkstra"
  where
   anchorDataFromPoolMetadata
     :: MonadError AnchorDataFromCertificateError m

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

@@ -100,6 +100,9 @@ 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)
+  Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (S (Z tx'))))))))) ->
+    let Consensus.ShelleyTx _txid shelleyEraTx = tx'
+     in TxInMode ShelleyBasedEraDijkstra (ShelleyTx ShelleyBasedEraDijkstra shelleyEraTx)
 
 toConsensusGenTx
   :: ()
@@ -132,6 +135,10 @@ toConsensusGenTx (TxInMode ShelleyBasedEraConway (ShelleyTx _ tx)) =
   Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (Z tx'))))))))
  where
   tx' = Consensus.mkShelleyTx tx
+toConsensusGenTx (TxInMode ShelleyBasedEraDijkstra (ShelleyTx _ tx)) =
+  Consensus.HardForkGenTx (Consensus.OneEraGenTx (S (S (S (S (S (S (S (Z tx')))))))))
+ where
+  tx' = Consensus.mkShelleyTx tx
 
 -- ----------------------------------------------------------------------------
 -- Transaction ids in the context of a consensus mode
@@ -193,6 +200,12 @@ toConsensusTxId (TxIdInMode ConwayEra txid) =
  where
   txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardConwayBlock)
   txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
+toConsensusTxId (TxIdInMode DijkstraEra txid) =
+  Consensus.HardForkGenTxId
+    (Consensus.OneEraGenTxId (S (S (S (S (S (S (S (Z (Consensus.WrapGenTxId txid'))))))))))
+ where
+  txid' :: Consensus.TxId (Consensus.GenTx Consensus.StandardDijkstraBlock)
+  txid' = Consensus.ShelleyTxId $ toShelleyTxId txid
 
 -- ----------------------------------------------------------------------------
 -- Transaction validation errors in the context of eras and consensus modes
@@ -300,5 +313,7 @@ fromConsensusApplyTxErr = \case
     TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraBabbage err
   Consensus.ApplyTxErrConway err ->
     TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraConway err
+  Consensus.ApplyTxErrDijkstra err ->
+    TxValidationErrorInCardanoMode $ ShelleyTxValidationError ShelleyBasedEraDijkstra err
   Consensus.ApplyTxErrWrongEra err ->
     TxValidationEraMismatch err

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

@@ -83,6 +83,7 @@ type family ConsensusBlockForEra era where
   ConsensusBlockForEra AlonzoEra = Consensus.StandardAlonzoBlock
   ConsensusBlockForEra BabbageEra = Consensus.StandardBabbageBlock
   ConsensusBlockForEra ConwayEra = Consensus.StandardConwayBlock
+  ConsensusBlockForEra DijkstraEra = Consensus.StandardDijkstraBlock
 
 type family ConsensusCryptoForBlock block where
   ConsensusCryptoForBlock Consensus.ByronBlockHFC = StandardCrypto
@@ -98,6 +99,7 @@ type family ConsensusProtocol era where
   ConsensusProtocol AlonzoEra = Consensus.TPraos StandardCrypto
   ConsensusProtocol BabbageEra = Consensus.Praos StandardCrypto
   ConsensusProtocol ConwayEra = Consensus.Praos StandardCrypto
+  ConsensusProtocol DijkstraEra = Consensus.Praos StandardCrypto
 
 type family ChainDepStateProtocol era where
   ChainDepStateProtocol ShelleyEra = Consensus.TPraosState
@@ -128,6 +130,9 @@ eraIndex5 = eraIndexSucc eraIndex4
 eraIndex6 :: Consensus.EraIndex (x6 : x5 : x4 : x3 : x2 : x1 : x0 : xs)
 eraIndex6 = eraIndexSucc eraIndex5
 
+eraIndex7 :: Consensus.EraIndex (x7 : x6 : x5 : x4 : x3 : x2 : x1 : x0 : xs)
+eraIndex7 = eraIndexSucc eraIndex6
+
 toConsensusEraIndex
   :: ()
   => Consensus.CardanoBlock StandardCrypto ~ Consensus.HardForkBlock xs
@@ -141,6 +146,7 @@ toConsensusEraIndex = \case
   AlonzoEra -> eraIndex4
   BabbageEra -> eraIndex5
   ConwayEra -> eraIndex6
+  DijkstraEra -> eraIndex7
 
 fromConsensusEraIndex
   :: ()
@@ -161,3 +167,4 @@ 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 _))))))) -> error "dijkstra"

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

@@ -295,6 +295,7 @@ type EraCommonConstraints era =
   , L.AlonzoEraTx (LedgerEra era)
   , L.BabbageEraPParams (LedgerEra era)
   , L.BabbageEraTxBody (LedgerEra era)
+  , L.ConwayEraTxBody (LedgerEra era)
   , L.ConwayEraTxCert (LedgerEra era)
   , L.TxCert (LedgerEra era) ~ L.ConwayTxCert (LedgerEra era)
   , L.Era (LedgerEra era)

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

@@ -211,3 +211,4 @@ obtainAlonzoScriptPurposeConstraints v =
     AlonzoEraOnwardsAlonzo -> id
     AlonzoEraOnwardsBabbage -> id
     AlonzoEraOnwardsConway -> id
+    AlonzoEraOnwardsDijkstra -> id

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
+    L.SPlutusV4 -> L.plutusLanguage l
 
 -- | 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)
 
@@ -285,7 +284,7 @@ makeUnsignedTx era bc = obtainCommonConstraints era $ do
           & L.datsTxWitsL .~ datums
           & L.rdmrsTxWitsL .~ redeemers
 
-  eraSpecificTxBody <- eraSpecificLedgerTxBody era ledgerTxBody bc
+  let eraSpecificTxBody = eraSpecificLedgerTxBody era ledgerTxBody bc
 
   return . UnsignedTx $
     L.mkBasicTx eraSpecificTxBody
@@ -297,22 +296,25 @@ eraSpecificLedgerTxBody
   :: Era era
   -> Ledger.TxBody (LedgerEra era)
   -> TxBodyContent BuildTx era
-  -> Either TxBodyError (Ledger.TxBody (LedgerEra era))
-eraSpecificLedgerTxBody ConwayEra ledgerbody bc =
-  let propProcedures = txProposalProcedures bc
-      voteProcedures = txVotingProcedures bc
-      treasuryDonation = txTreasuryDonation bc
-      currentTresuryValue = txCurrentTreasuryValue bc
-   in return $
-        ledgerbody
-          & L.proposalProceduresTxBodyL
-            .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured propProcedures)
-          & L.votingProceduresTxBodyL
-            .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures)
-          & L.treasuryDonationTxBodyL
-            .~ maybe (L.Coin 0) unFeatured treasuryDonation
-          & L.currentTreasuryValueTxBodyL
-            .~ L.maybeToStrictMaybe (unFeatured =<< currentTresuryValue)
+  -> Ledger.TxBody (LedgerEra era)
+eraSpecificLedgerTxBody era ledgerbody bc =
+  body era
+ where
+  body e =
+    let propProcedures = txProposalProcedures bc
+        voteProcedures = txVotingProcedures bc
+        treasuryDonation = txTreasuryDonation bc
+        currentTresuryValue = txCurrentTreasuryValue bc
+     in obtainCommonConstraints e $
+          ledgerbody
+            & L.proposalProceduresTxBodyL
+              .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured propProcedures)
+            & L.votingProceduresTxBodyL
+              .~ convVotingProcedures (maybe TxVotingProceduresNone unFeatured voteProcedures)
+            & L.treasuryDonationTxBodyL
+              .~ maybe (L.Coin 0) unFeatured treasuryDonation
+            & L.currentTreasuryValueTxBodyL
+              .~ L.maybeToStrictMaybe (unFeatured =<< currentTresuryValue)
 
 hashTxBody
   :: L.HashAnnotated (Ledger.TxBody era) L.EraIndependentTxBody

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

@@ -29,6 +29,7 @@ import Cardano.Ledger.Alonzo.Scripts qualified as L
 import Cardano.Ledger.Babbage.Scripts qualified as L
 import Cardano.Ledger.Conway.Scripts qualified as L
 import Cardano.Ledger.Core qualified as L
+import Cardano.Ledger.Dijkstra.Scripts qualified as Dijkstra
 import Cardano.Ledger.Plutus.Data qualified as L
 import Cardano.Ledger.Plutus.Language qualified as L
 
@@ -101,12 +102,14 @@ getAnyWitnessScript era ss@(AnySimpleScriptWitness{}) =
     ShelleyBasedEraAlonzo -> L.TimelockScript <$> getAnyWitnessSimpleScript ss
     ShelleyBasedEraBabbage -> L.TimelockScript <$> getAnyWitnessSimpleScript ss
     ShelleyBasedEraConway -> L.TimelockScript <$> getAnyWitnessSimpleScript ss
+    ShelleyBasedEraDijkstra -> L.TimelockScript <$> getAnyWitnessSimpleScript ss
 getAnyWitnessScript era ps@(AnyPlutusScriptWitness{}) =
   forShelleyBasedEraInEon era Nothing $ \aEon ->
     case aEon of
       AlonzoEraOnwardsAlonzo -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps
       AlonzoEraOnwardsBabbage -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps
       AlonzoEraOnwardsConway -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps
+      AlonzoEraOnwardsDijkstra -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps
 
 -- It should be noted that 'PlutusRunnable' is constructed via deserialization. The deserialization
 -- instance lives in ledger and will fail for an invalid script language/era pairing. Therefore
@@ -127,6 +130,9 @@ fromPlutusRunnable L.SPlutusV1 eon runnable =
     AlonzoEraOnwardsConway ->
       let plutusScript = L.plutusFromRunnable runnable
        in Just $ L.ConwayPlutusV1 plutusScript
+    AlonzoEraOnwardsDijkstra ->
+      let plutusScript = L.plutusFromRunnable runnable
+       in Just $ Dijkstra.MkDijkstraPlutusScript $ L.ConwayPlutusV1 plutusScript
 fromPlutusRunnable L.SPlutusV2 eon runnable =
   case eon of
     AlonzoEraOnwardsAlonzo -> Nothing
@@ -136,13 +142,29 @@ fromPlutusRunnable L.SPlutusV2 eon runnable =
     AlonzoEraOnwardsConway ->
       let plutusScript = L.plutusFromRunnable runnable
        in Just $ L.ConwayPlutusV2 plutusScript
+    AlonzoEraOnwardsDijkstra ->
+      let plutusScript = L.plutusFromRunnable runnable
+       in Just $ Dijkstra.MkDijkstraPlutusScript $ L.ConwayPlutusV2 plutusScript
 fromPlutusRunnable L.SPlutusV3 eon runnable =
   case eon of
     AlonzoEraOnwardsAlonzo -> Nothing
     AlonzoEraOnwardsBabbage -> Nothing
     AlonzoEraOnwardsConway ->
       let plutusScript = L.plutusFromRunnable runnable
        in Just $ L.ConwayPlutusV3 plutusScript
+    AlonzoEraOnwardsDijkstra ->
+      let plutusScript = L.plutusFromRunnable runnable
+       in Just $ Dijkstra.MkDijkstraPlutusScript $ L.ConwayPlutusV3 plutusScript
+fromPlutusRunnable L.SPlutusV4 eon runnable =
+  case eon of
+    AlonzoEraOnwardsAlonzo -> Nothing
+    AlonzoEraOnwardsBabbage -> Nothing
+    AlonzoEraOnwardsConway ->
+      let plutusScript = L.plutusFromRunnable runnable
+       in Just $ (error "ConwayPlutusV4") plutusScript
+    AlonzoEraOnwardsDijkstra ->
+      let plutusScript = L.plutusFromRunnable runnable
+       in Just $ Dijkstra.MkDijkstraPlutusScript $ (error "ConwayPlutusV4") plutusScript
 
 toAlonzoDatum
   :: AlonzoEraOnwards era
@@ -160,5 +182,6 @@ getPlutusDatum
 getPlutusDatum L.SPlutusV1 (SpendingScriptDatum d) = Just d
 getPlutusDatum L.SPlutusV2 (SpendingScriptDatum d) = Just d
 getPlutusDatum L.SPlutusV3 (SpendingScriptDatum d) = d
+getPlutusDatum L.SPlutusV4 (SpendingScriptDatum _d) = error "dijkstra"
 getPlutusDatum _ InlineDatum = Nothing
 getPlutusDatum _ NoScriptDatum = Nothing