Skip to content

Commit fdce7e9

Browse files
Jimbo4350Jimbo4350
committed
WIP
1 parent a003d54 commit fdce7e9

File tree

21 files changed

+272
-37
lines changed

21 files changed

+272
-37
lines changed

‎cardano-api/cardano-api.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -296,6 +296,7 @@ library gen
296296
Test.Gen.Cardano.Api.Era
297297
Test.Gen.Cardano.Api.Hardcoded
298298
Test.Gen.Cardano.Api.Metadata
299+
Test.Gen.Cardano.Api.Orphans
299300
Test.Gen.Cardano.Api.ProtocolParameters
300301
Test.Gen.Cardano.Api.Typed
301302
Test.Gen.Cardano.Crypto.Seed
@@ -316,9 +317,11 @@ library gen
316317
cardano-ledger-byron-test >=1.5,
317318
cardano-ledger-conway:testlib,
318319
cardano-ledger-core:{cardano-ledger-core, testlib} >=1.14,
320+
cardano-ledger-dijkstra >=0.1,
319321
cardano-ledger-shelley >=1.13,
320322
containers,
321323
filepath,
324+
generic-random,
322325
hedgehog >=1.1,
323326
hedgehog-extras,
324327
hedgehog-quickcheck,

‎cardano-api/gen/Test/Gen/Cardano/Api/Era.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,8 @@ import Cardano.Ledger.Core qualified as Ledger
1717

1818
import Data.Functor.Identity qualified as Ledger
1919

20+
import Test.Gen.Cardano.Api.Orphans ()
21+
2022
import Test.Cardano.Ledger.Conway.Arbitrary ()
2123
import Test.Cardano.Ledger.Core.Arbitrary ()
2224

@@ -39,6 +41,7 @@ shelleyBasedEraTestConstraints = \case
3941
ShelleyBasedEraAlonzo -> id
4042
ShelleyBasedEraBabbage -> id
4143
ShelleyBasedEraConway -> id
44+
ShelleyBasedEraDijkstra -> id
4245

4346
shelleyToBabbageEraTestConstraints
4447
:: ()
@@ -69,3 +72,4 @@ conwayEraOnwardsTestConstraints
6972
-> a
7073
conwayEraOnwardsTestConstraints = \case
7174
ConwayEraOnwardsConway -> id
75+
ConwayEraOnwardsDijkstra -> id

‎cardano-api/gen/Test/Gen/Cardano/Api/Orphans.hs‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
{-# LANGUAGE DerivingStrategies #-}
2+
{-# LANGUAGE FlexibleInstances #-}
3+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
{-# LANGUAGE StandaloneDeriving #-}
5+
{-# OPTIONS_GHC -Wno-orphans #-}
6+
7+
module Test.Gen.Cardano.Api.Orphans
8+
(
9+
)
10+
where
11+
12+
import Cardano.Ledger.BaseTypes (StrictMaybe)
13+
import Cardano.Ledger.Dijkstra (DijkstraEra)
14+
import Cardano.Ledger.Dijkstra.PParams (DijkstraPParams)
15+
16+
import Data.Functor.Identity (Identity)
17+
import Generic.Random (genericArbitraryU)
18+
import Test.Cardano.Ledger.Common (Arbitrary (..))
19+
import Test.Cardano.Ledger.Conway.Arbitrary ()
20+
21+
22+
instance Arbitrary (DijkstraPParams Identity DijkstraEra) where
23+
arbitrary = genericArbitraryU
24+
25+
instance Arbitrary (DijkstraPParams StrictMaybe DijkstraEra) where
26+
arbitrary = genericArbitraryU

‎cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1327,6 +1327,13 @@ genTxOutDatumHashTxContext era = case era of
13271327
, TxOutSupplementalDatum AlonzoEraOnwardsConway <$> genHashableScriptData
13281328
, TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData
13291329
]
1330+
ShelleyBasedEraDijkstra ->
1331+
Gen.choice
1332+
[ pure TxOutDatumNone
1333+
, TxOutDatumHash AlonzoEraOnwardsDijkstra <$> genHashScriptData
1334+
, TxOutSupplementalDatum AlonzoEraOnwardsDijkstra <$> genHashableScriptData
1335+
, TxOutDatumInline BabbageEraOnwardsDijkstra <$> genHashableScriptData
1336+
]
13301337

13311338
genTxOutDatumHashUTxOContext :: ShelleyBasedEra era -> Gen (TxOutDatum CtxUTxO era)
13321339
genTxOutDatumHashUTxOContext era = case era of
@@ -1350,6 +1357,12 @@ genTxOutDatumHashUTxOContext era = case era of
13501357
, TxOutDatumHash AlonzoEraOnwardsConway <$> genHashScriptData
13511358
, TxOutDatumInline BabbageEraOnwardsConway <$> genHashableScriptData
13521359
]
1360+
ShelleyBasedEraDijkstra ->
1361+
Gen.choice
1362+
[ pure TxOutDatumNone
1363+
, TxOutDatumHash AlonzoEraOnwardsDijkstra <$> genHashScriptData
1364+
, TxOutDatumInline BabbageEraOnwardsDijkstra <$> genHashableScriptData
1365+
]
13531366

13541367
mkDummyHash :: forall h a. CRYPTO.HashAlgorithm h => Int -> CRYPTO.Hash h a
13551368
mkDummyHash = coerce . CRYPTO.hashWithSerialiser @h CBOR.toCBOR

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

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -234,6 +234,7 @@ certificateToTxCert c =
234234
ConwayCertificate eon cert ->
235235
case eon of
236236
ConwayEraOnwardsConway -> cert
237+
ConwayEraOnwardsDijkstra -> cert
237238

238239
-- ----------------------------------------------------------------------------
239240
-- Stake pool parameters
@@ -576,6 +577,7 @@ filterUnRegCreds =
576577
Ledger.RetirePoolTxCert _ _ -> Nothing
577578
Ledger.MirTxCert _ -> Nothing
578579
Ledger.GenesisDelegTxCert{} -> Nothing
580+
_ -> error "dijkstra"
579581
ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $
580582
case conwayCert of
581583
Ledger.RegPoolTxCert _ -> Nothing
@@ -593,6 +595,7 @@ filterUnRegCreds =
593595
Ledger.RegTxCert _ -> Nothing
594596
-- stake cred deregistration w/o deposit
595597
Ledger.UnRegTxCert cred -> Just cred
598+
_ -> error "dijkstra"
596599

597600
filterUnRegDRepCreds
598601
:: Certificate era -> Maybe (Ledger.Credential Ledger.DRepRole)
@@ -615,6 +618,7 @@ filterUnRegDRepCreds = \case
615618
Ledger.RegTxCert _ -> Nothing
616619
-- stake cred deregistration w/o deposit
617620
Ledger.UnRegTxCert _ -> Nothing
621+
_ -> error "dijkstra"
618622

619623
-- ----------------------------------------------------------------------------
620624
-- Internal conversion functions
@@ -803,6 +807,7 @@ getAnchorDataFromCertificate c =
803807
Ledger.RetirePoolTxCert _ _ -> return Nothing
804808
Ledger.GenesisDelegTxCert{} -> return Nothing
805809
Ledger.MirTxCert _ -> return Nothing
810+
_ -> error "dijkstra"
806811
ConwayCertificate ceo ccert ->
807812
conwayEraOnwardsConstraints ceo $
808813
case ccert of
@@ -819,6 +824,7 @@ getAnchorDataFromCertificate c =
819824
Ledger.UpdateDRepTxCert _ mAnchor -> return $ Ledger.strictMaybeToMaybe mAnchor
820825
Ledger.AuthCommitteeHotKeyTxCert _ _ -> return Nothing
821826
Ledger.ResignCommitteeColdTxCert _ mAnchor -> return $ Ledger.strictMaybeToMaybe mAnchor
827+
_ -> error "dijkstra"
822828
where
823829
anchorDataFromPoolMetadata
824830
:: MonadError AnchorDataFromCertificateError m

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -295,6 +295,7 @@ type EraCommonConstraints era =
295295
, L.AlonzoEraTx (LedgerEra era)
296296
, L.BabbageEraPParams (LedgerEra era)
297297
, L.BabbageEraTxBody (LedgerEra era)
298+
, L.ConwayEraTxBody (LedgerEra era)
298299
, L.ConwayEraTxCert (LedgerEra era)
299300
, L.TxCert (LedgerEra era) ~ L.ConwayTxCert (LedgerEra era)
300301
, L.Era (LedgerEra era)

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -211,3 +211,4 @@ obtainAlonzoScriptPurposeConstraints v =
211211
AlonzoEraOnwardsAlonzo -> id
212212
AlonzoEraOnwardsBabbage -> id
213213
AlonzoEraOnwardsConway -> id
214+
AlonzoEraOnwardsDijkstra -> id

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -74,6 +74,7 @@ getPlutusScriptWitnessLanguage (PlutusScriptWitness l _ _ _ _) =
7474
L.SPlutusV1 -> L.plutusLanguage l
7575
L.SPlutusV2 -> L.plutusLanguage l
7676
L.SPlutusV3 -> L.plutusLanguage l
77+
L.SPlutusV4 -> L.plutusLanguage l
7778

7879
-- | Every Plutus script has a purpose that indicates
7980
-- what that script is witnessing.

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

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ import Cardano.Ledger.Alonzo.Scripts qualified as L
2929
import Cardano.Ledger.Babbage.Scripts qualified as L
3030
import Cardano.Ledger.Conway.Scripts qualified as L
3131
import Cardano.Ledger.Core qualified as L
32+
import Cardano.Ledger.Dijkstra.Scripts qualified as Dijkstra
3233
import Cardano.Ledger.Plutus.Data qualified as L
3334
import Cardano.Ledger.Plutus.Language qualified as L
3435

@@ -101,12 +102,14 @@ getAnyWitnessScript era ss@(AnySimpleScriptWitness{}) =
101102
ShelleyBasedEraAlonzo -> L.TimelockScript <$> getAnyWitnessSimpleScript ss
102103
ShelleyBasedEraBabbage -> L.TimelockScript <$> getAnyWitnessSimpleScript ss
103104
ShelleyBasedEraConway -> L.TimelockScript <$> getAnyWitnessSimpleScript ss
105+
ShelleyBasedEraDijkstra -> L.TimelockScript <$> getAnyWitnessSimpleScript ss
104106
getAnyWitnessScript era ps@(AnyPlutusScriptWitness{}) =
105107
forShelleyBasedEraInEon era Nothing $ \aEon ->
106108
case aEon of
107109
AlonzoEraOnwardsAlonzo -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps
108110
AlonzoEraOnwardsBabbage -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps
109111
AlonzoEraOnwardsConway -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps
112+
AlonzoEraOnwardsDijkstra -> L.PlutusScript <$> getAnyWitnessPlutusScript aEon ps
110113

111114
-- It should be noted that 'PlutusRunnable' is constructed via deserialization. The deserialization
112115
-- instance lives in ledger and will fail for an invalid script language/era pairing. Therefore
@@ -127,6 +130,9 @@ fromPlutusRunnable L.SPlutusV1 eon runnable =
127130
AlonzoEraOnwardsConway ->
128131
let plutusScript = L.plutusFromRunnable runnable
129132
in Just $ L.ConwayPlutusV1 plutusScript
133+
AlonzoEraOnwardsDijkstra ->
134+
let plutusScript = L.plutusFromRunnable runnable
135+
in Just $ Dijkstra.MkDijkstraPlutusScript $ L.ConwayPlutusV1 plutusScript
130136
fromPlutusRunnable L.SPlutusV2 eon runnable =
131137
case eon of
132138
AlonzoEraOnwardsAlonzo -> Nothing
@@ -136,13 +142,29 @@ fromPlutusRunnable L.SPlutusV2 eon runnable =
136142
AlonzoEraOnwardsConway ->
137143
let plutusScript = L.plutusFromRunnable runnable
138144
in Just $ L.ConwayPlutusV2 plutusScript
145+
AlonzoEraOnwardsDijkstra ->
146+
let plutusScript = L.plutusFromRunnable runnable
147+
in Just $ Dijkstra.MkDijkstraPlutusScript $ L.ConwayPlutusV2 plutusScript
139148
fromPlutusRunnable L.SPlutusV3 eon runnable =
140149
case eon of
141150
AlonzoEraOnwardsAlonzo -> Nothing
142151
AlonzoEraOnwardsBabbage -> Nothing
143152
AlonzoEraOnwardsConway ->
144153
let plutusScript = L.plutusFromRunnable runnable
145154
in Just $ L.ConwayPlutusV3 plutusScript
155+
AlonzoEraOnwardsDijkstra ->
156+
let plutusScript = L.plutusFromRunnable runnable
157+
in Just $ Dijkstra.MkDijkstraPlutusScript $ L.ConwayPlutusV3 plutusScript
158+
fromPlutusRunnable L.SPlutusV4 eon runnable =
159+
case eon of
160+
AlonzoEraOnwardsAlonzo -> Nothing
161+
AlonzoEraOnwardsBabbage -> Nothing
162+
AlonzoEraOnwardsConway ->
163+
let plutusScript = L.plutusFromRunnable runnable
164+
in Just $ (error "ConwayPlutusV4") plutusScript
165+
AlonzoEraOnwardsDijkstra ->
166+
let plutusScript = L.plutusFromRunnable runnable
167+
in Just $ Dijkstra.MkDijkstraPlutusScript $ (error "ConwayPlutusV4") plutusScript
146168

147169
toAlonzoDatum
148170
:: AlonzoEraOnwards era
@@ -160,5 +182,6 @@ getPlutusDatum
160182
getPlutusDatum L.SPlutusV1 (SpendingScriptDatum d) = Just d
161183
getPlutusDatum L.SPlutusV2 (SpendingScriptDatum d) = Just d
162184
getPlutusDatum L.SPlutusV3 (SpendingScriptDatum d) = d
185+
getPlutusDatum L.SPlutusV4 (SpendingScriptDatum _d) = error "dijkstra"
163186
getPlutusDatum _ InlineDatum = Nothing
164187
getPlutusDatum _ NoScriptDatum = Nothing

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

Lines changed: 65 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE RankNTypes #-}
55
{-# LANGUAGE StandaloneDeriving #-}
66
{-# LANGUAGE TupleSections #-}
7+
{-# LANGUAGE TypeApplications #-}
78

89
module Cardano.Api.Experimental.Tx.Internal.Certificate
910
( Certificate (..)
@@ -15,8 +16,8 @@ where
1516

1617
import Cardano.Api.Address qualified as Api
1718
import Cardano.Api.Certificate.Internal qualified as Api
19+
import Cardano.Api.Era.Internal.Core (DijkstraEra)
1820
import Cardano.Api.Era.Internal.Eon.Convert
19-
import Cardano.Api.Era.Internal.Eon.ConwayEraOnwards
2021
import Cardano.Api.Era.Internal.Eon.ShelleyToBabbageEra qualified as Api
2122
import Cardano.Api.Experimental.Era
2223
import Cardano.Api.Experimental.Plutus.Internal.Script qualified as Exp
@@ -45,13 +46,18 @@ deriving instance Eq (Certificate era)
4546
deriving instance Ord (Certificate era)
4647

4748
convertToOldApiCertificate :: Era era -> Certificate (LedgerEra era) -> Api.Certificate era
48-
convertToOldApiCertificate ConwayEra (Certificate cert) =
49-
Api.ConwayCertificate ConwayEraOnwardsConway cert
49+
convertToOldApiCertificate e (Certificate cert) =
50+
obtainCommonConstraints e $ Api.ConwayCertificate (convert e) cert
5051

5152
convertToNewCertificate :: Era era -> Api.Certificate era -> Certificate (LedgerEra era)
52-
convertToNewCertificate ConwayEra (Api.ConwayCertificate _ cert) = Certificate cert
53-
convertToNewCertificate ConwayEra (Api.ShelleyRelatedCertificate sToBab _) =
54-
case sToBab :: Api.ShelleyToBabbageEra ConwayEra of {}
53+
convertToNewCertificate era (Api.ConwayCertificate _ cert) =
54+
case era of
55+
ConwayEra -> Certificate cert
56+
DijkstraEra -> Certificate cert
57+
convertToNewCertificate era (Api.ShelleyRelatedCertificate sToBab _) =
58+
case era of
59+
ConwayEra -> case sToBab :: Api.ShelleyToBabbageEra ConwayEra of {}
60+
DijkstraEra -> case sToBab :: Api.ShelleyToBabbageEra DijkstraEra of {}
5561

5662
mkTxCertificates
5763
:: forall era
@@ -61,29 +67,29 @@ mkTxCertificates
6167
mkTxCertificates [] = TxCertificatesNone
6268
mkTxCertificates certs =
6369
TxCertificates (convert useEra) $ fromList $ map (getStakeCred useEra) certs
64-
where
65-
getStakeCred
66-
:: Era era
67-
-> (Certificate (LedgerEra era), AnyWitness (LedgerEra era))
68-
-> ( Api.Certificate era
69-
, Api.BuildTxWith
70-
Api.BuildTx
71-
(Maybe (Api.StakeCredential, Api.Witness Api.WitCtxStake era))
72-
)
73-
getStakeCred era (Certificate cert, witness) =
74-
case era of
75-
ConwayEra -> do
76-
let oldApiCert = Api.ConwayCertificate (convert era) cert
77-
mStakeCred = Api.selectStakeCredentialWitness oldApiCert
78-
wit =
79-
case witness of
80-
AnyKeyWitnessPlaceholder -> Api.KeyWitness Api.KeyWitnessForStakeAddr
81-
AnySimpleScriptWitness ss ->
82-
Api.ScriptWitness Api.ScriptWitnessForStakeAddr $ newToOldSimpleScriptWitness era ss
83-
AnyPlutusScriptWitness psw ->
84-
Api.ScriptWitness Api.ScriptWitnessForStakeAddr $
85-
newToOldPlutusCertificateScriptWitness ConwayEra psw
86-
(oldApiCert, pure $ (,wit) <$> mStakeCred)
70+
71+
getStakeCred
72+
:: Era era
73+
-> (Certificate (LedgerEra era), AnyWitness (LedgerEra era))
74+
-> ( Api.Certificate era
75+
, Api.BuildTxWith
76+
Api.BuildTx
77+
(Maybe (Api.StakeCredential, Api.Witness Api.WitCtxStake era))
78+
)
79+
getStakeCred e (Certificate cert, witness) = do
80+
let oldApiCert = obtainCommonConstraints e $ Api.ConwayCertificate (convert e) cert
81+
mStakeCred = Api.selectStakeCredentialWitness oldApiCert
82+
wit =
83+
case witness of
84+
AnyKeyWitnessPlaceholder -> Api.KeyWitness Api.KeyWitnessForStakeAddr
85+
AnySimpleScriptWitness ss ->
86+
Api.ScriptWitness Api.ScriptWitnessForStakeAddr $
87+
obtainCommonConstraints e $
88+
newToOldSimpleScriptWitness e ss
89+
AnyPlutusScriptWitness psw ->
90+
Api.ScriptWitness Api.ScriptWitnessForStakeAddr $
91+
newToOldPlutusCertificateScriptWitness e psw
92+
(oldApiCert, pure $ (,wit) <$> mStakeCred)
8793

8894
newToOldSimpleScriptWitness
8995
:: L.AllegraEraScript (LedgerEra era)
@@ -127,12 +133,40 @@ newToOldPlutusCertificateScriptWitness ConwayEra (Exp.PlutusScriptWitness Plutus
127133
Api.NoScriptDatumForStake
128134
redeemer
129135
execUnits
136+
newToOldPlutusCertificateScriptWitness ConwayEra (Exp.PlutusScriptWitness Plutus.SPlutusV4 _scriptOrRef _ _redeemer _execUnits) =
137+
error "dijkstra"
138+
newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV1 scriptOrRef _ redeemer execUnits) =
139+
Api.PlutusScriptWitness
140+
Api.PlutusScriptV1InDijkstra
141+
Api.PlutusScriptV1
142+
(newToOldPlutusScriptOrReferenceInput DijkstraEra scriptOrRef)
143+
Api.NoScriptDatumForStake
144+
redeemer
145+
execUnits
146+
newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV2 scriptOrRef _ redeemer execUnits) =
147+
Api.PlutusScriptWitness
148+
Api.PlutusScriptV2InDijkstra
149+
Api.PlutusScriptV2
150+
(newToOldPlutusScriptOrReferenceInput DijkstraEra scriptOrRef)
151+
Api.NoScriptDatumForStake
152+
redeemer
153+
execUnits
154+
newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV3 scriptOrRef _ redeemer execUnits) =
155+
Api.PlutusScriptWitness
156+
Api.PlutusScriptV3InDijkstra
157+
Api.PlutusScriptV3
158+
(newToOldPlutusScriptOrReferenceInput DijkstraEra scriptOrRef)
159+
Api.NoScriptDatumForStake
160+
redeemer
161+
execUnits
162+
newToOldPlutusCertificateScriptWitness DijkstraEra (Exp.PlutusScriptWitness Plutus.SPlutusV4 _scriptOrRef _ _redeemer _execUnits) =
163+
error "dijkstra"
130164

131165
newToOldPlutusScriptOrReferenceInput
132166
:: Era era
133167
-> Exp.PlutusScriptOrReferenceInput lang (LedgerEra era)
134168
-> Api.PlutusScriptOrReferenceInput oldlang
135-
newToOldPlutusScriptOrReferenceInput ConwayEra (Exp.PReferenceScript txin) = Api.PReferenceScript txin
136-
newToOldPlutusScriptOrReferenceInput ConwayEra (Exp.PScript (Exp.PlutusScriptInEra plutusRunnable)) =
169+
newToOldPlutusScriptOrReferenceInput _ (Exp.PReferenceScript txin) = Api.PReferenceScript txin
170+
newToOldPlutusScriptOrReferenceInput _ (Exp.PScript (Exp.PlutusScriptInEra plutusRunnable)) =
137171
let oldScript = L.unPlutusBinary . L.plutusBinary $ L.plutusFromRunnable plutusRunnable
138172
in Api.PScript $ Api.PlutusScriptSerialised oldScript

0 commit comments

Comments
 (0)