Skip to content

Commit 5717284

Browse files
Jimbo4350Jimbo4350
committed
Everything passes
1 parent a91cc5d commit 5717284

File tree

9 files changed

+331
-409
lines changed

9 files changed

+331
-409
lines changed

‎cardano-api/cardano-api.cabal‎

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -227,15 +227,17 @@ library
227227
Cardano.Api.Experimental.Plutus.Internal.Script
228228
Cardano.Api.Experimental.Plutus.Internal.ScriptWitness
229229
Cardano.Api.Experimental.Plutus.Internal.Shim.LegacyScripts
230+
Cardano.Api.Experimental.Script
230231
Cardano.Api.Experimental.Serialise.TextEnvelope.Internal
231232
Cardano.Api.Experimental.Tx.Internal.AnyWitness
232-
Cardano.Api.Experimental.Tx.Internal.Body
233+
Cardano.Api.Experimental.Tx.Internal.BodyContent.New
233234
Cardano.Api.Experimental.Tx.Internal.Certificate
234235
Cardano.Api.Experimental.Tx.Internal.Certificate.Compatible
235236
Cardano.Api.Experimental.Tx.Internal.Certificate.Type
236237
Cardano.Api.Experimental.Tx.Internal.Compatible
237238
Cardano.Api.Experimental.Tx.Internal.Fee
238239
Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements
240+
Cardano.Api.Experimental.Tx.Internal.Type
239241
Cardano.Api.Genesis.Internal
240242
Cardano.Api.Genesis.Internal.Parameters
241243
Cardano.Api.Governance.Internal.Action.ProposalProcedure
@@ -306,6 +308,7 @@ library gen
306308
Test.Gen.Cardano.Api
307309
Test.Gen.Cardano.Api.Byron
308310
Test.Gen.Cardano.Api.Era
311+
Test.Gen.Cardano.Api.Experimental
309312
Test.Gen.Cardano.Api.Hardcoded
310313
Test.Gen.Cardano.Api.Metadata
311314
Test.Gen.Cardano.Api.Orphans
@@ -343,6 +346,7 @@ library gen
343346
hedgehog-extras,
344347
hedgehog-quickcheck,
345348
iproute,
349+
ordered-containers,
346350
quickcheck-instances,
347351
random,
348352
tasty,
@@ -386,6 +390,7 @@ test-suite cardano-api-test
386390
hedgehog >=1.1,
387391
hedgehog-extras,
388392
hedgehog-quickcheck,
393+
ordered-containers,
389394
microlens,
390395
mtl,
391396
ouroboros-consensus,

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

Lines changed: 88 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,88 @@
1+
module Test.Gen.Cardano.Api.Experimental
2+
( genScriptWitnessedTxCertificates
3+
, genScriptWitnessedTxIn
4+
, genScriptWitnessedTxMintValue
5+
, genScriptWitnessedTxProposals
6+
, genScriptWitnesssedTxVotingProcedures
7+
, genScriptWitnessedTxWithdrawals
8+
)
9+
where
10+
11+
import Cardano.Api (TxIn)
12+
import Cardano.Api.Experimental
13+
import Cardano.Api.Experimental.Tx
14+
import Cardano.Api.Ledger qualified as L
15+
16+
import Data.Map.Ordered.Strict qualified as OMap
17+
18+
import Test.Gen.Cardano.Api.Typed (genExecutionUnits, genHashableScriptData, genTxIn)
19+
20+
import Hedgehog (Gen)
21+
import Hedgehog.Gen qualified as Gen
22+
23+
genAnyWitness :: Gen (AnyWitness era)
24+
genAnyWitness =
25+
Gen.choice
26+
[ return AnyKeyWitnessPlaceholder
27+
, AnySimpleScriptWitness <$> genAnySimpleScriptWitness
28+
, Gen.choice
29+
[ genAnyPlutusScriptWitnessV1
30+
, genAnyPlutusScriptWitnessV2
31+
, genAnyPlutusScriptWitnessV3
32+
, genAnyPlutusScriptWitnessV4
33+
]
34+
]
35+
36+
genAnyPlutusScriptWitnessV1 :: Gen (AnyWitness era)
37+
genAnyPlutusScriptWitnessV1 =
38+
AnyPlutusScriptWitness <$> genPlutusScriptWitness L.SPlutusV1
39+
40+
genAnyPlutusScriptWitnessV2 :: Gen (AnyWitness era)
41+
genAnyPlutusScriptWitnessV2 =
42+
AnyPlutusScriptWitness <$> genPlutusScriptWitness L.SPlutusV2
43+
44+
genAnyPlutusScriptWitnessV3 :: Gen (AnyWitness era)
45+
genAnyPlutusScriptWitnessV3 =
46+
AnyPlutusScriptWitness <$> genPlutusScriptWitness L.SPlutusV3
47+
48+
genAnyPlutusScriptWitnessV4 :: Gen (AnyWitness era)
49+
genAnyPlutusScriptWitnessV4 =
50+
AnyPlutusScriptWitness <$> genPlutusScriptWitness L.SPlutusV4
51+
52+
genAnySimpleScriptWitness :: Gen (SimpleScriptOrReferenceInput era)
53+
genAnySimpleScriptWitness = SReferenceScript <$> genTxIn
54+
55+
-- TODO: <|> (SScript <$> genSimpleScriptWitness)
56+
57+
genPlutusScriptWitness :: L.SLanguage lang -> Gen (PlutusScriptWitness lang purpose era)
58+
genPlutusScriptWitness l =
59+
PlutusScriptWitness l
60+
<$> genPlutusScript
61+
<*> genMaybeDatum
62+
<*> genHashableScriptData
63+
<*> genExecutionUnits
64+
65+
genPlutusScript :: Gen (PlutusScriptOrReferenceInput era lang)
66+
genPlutusScript = PReferenceScript <$> genTxIn
67+
68+
genMaybeDatum :: Gen (PlutusScriptDatum lang purpose)
69+
genMaybeDatum = return NoScriptDatum -- TODO: Write proper generator
70+
71+
genScriptWitnessedTxIn :: Gen (TxIn, AnyWitness era)
72+
genScriptWitnessedTxIn = do
73+
(,) <$> genTxIn <*> genAnyWitness
74+
75+
genScriptWitnessedTxMintValue :: Gen (TxMintValue era)
76+
genScriptWitnessedTxMintValue = return $ TxMintValue mempty
77+
78+
genScriptWitnessedTxCertificates :: Gen (TxCertificates era)
79+
genScriptWitnessedTxCertificates = return $ TxCertificates OMap.empty
80+
81+
genScriptWitnessedTxWithdrawals :: Gen (TxWithdrawals era)
82+
genScriptWitnessedTxWithdrawals = return $ TxWithdrawals mempty
83+
84+
genScriptWitnesssedTxVotingProcedures :: Gen (TxVotingProcedures era)
85+
genScriptWitnesssedTxVotingProcedures = return $ TxVotingProcedures (L.VotingProcedures mempty) mempty
86+
87+
genScriptWitnessedTxProposals :: Gen (TxProposalProcedures era)
88+
genScriptWitnessedTxProposals = return $ TxProposalProcedures OMap.empty

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

Lines changed: 21 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -124,6 +124,26 @@ module Cardano.Api.Experimental.Tx
124124
, convertTxBodyToUnsignedTx
125125
, hashTxBody
126126

127+
-- * TxBodyContent
128+
, TxBodyContent (..)
129+
, defaultTxBodyContent
130+
, setTxCertificates
131+
, setTxIns
132+
, setTxOuts
133+
, setTxMintValue
134+
, setTxProposalProcedures
135+
, setTxVotingProcedures
136+
, setTxWithdrawals
137+
, setTxFee
138+
139+
-- * TxBodyContent sub type
140+
, TxCertificates (..)
141+
, TxMintValue (..)
142+
, TxOut (..)
143+
, TxProposalProcedures (..)
144+
, TxVotingProcedures (..)
145+
, TxWithdrawals (..)
146+
127147
-- * Witness
128148

129149
-- ** Any witness (key, simple script, plutus script).
@@ -150,10 +170,7 @@ import Cardano.Api.Era.Internal.Core qualified as Api
150170
import Cardano.Api.Era.Internal.Eon.ShelleyBasedEra
151171
import Cardano.Api.Experimental.Era
152172
import Cardano.Api.Experimental.Tx.Internal.AnyWitness
153-
import Cardano.Api.Experimental.Tx.Internal.BodyContent.Old
154-
( extractAllIndexedPlutusScriptWitnesses
155-
, makeUnsignedTx
156-
)
173+
import Cardano.Api.Experimental.Tx.Internal.BodyContent.New
157174
import Cardano.Api.Experimental.Tx.Internal.TxScriptWitnessRequirements
158175
import Cardano.Api.Experimental.Tx.Internal.Type
159176
import Cardano.Api.HasTypeProxy (HasTypeProxy (..), Proxy, asType)

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

Lines changed: 90 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -19,10 +19,21 @@ module Cardano.Api.Experimental.Tx.Internal.BodyContent.New
1919
, TxVotingProcedures (..)
2020
, TxWithdrawals (..)
2121
, TxBodyContent (..)
22+
, defaultTxBodyContent
2223
, collectTxBodyScriptWitnessRequirements
23-
, createUnsignedTx
24+
, makeUnsignedTx
2425
, extractAllIndexedPlutusScriptWitnesses
2526
, txMintValueToValue
27+
28+
-- * Getters and Setters
29+
, setTxCertificates
30+
, setTxIns
31+
, setTxFee
32+
, setTxOuts
33+
, setTxMintValue
34+
, setTxProposalProcedures
35+
, setTxVotingProcedures
36+
, setTxWithdrawals
2637
)
2738
where
2839

@@ -71,6 +82,7 @@ import Control.Monad
7182
import Data.Functor
7283
import Data.List qualified as List
7384
import Data.Map.Ordered.Strict (OMap)
85+
import Data.Map.Ordered.Strict qualified as OMap
7486
import Data.Map.Strict (Map)
7587
import Data.Map.Strict qualified as Map
7688
import Data.Maybe
@@ -82,13 +94,13 @@ import Data.Set qualified as Set
8294
import GHC.Exts (IsList (..))
8395
import Lens.Micro
8496

85-
createUnsignedTx
97+
makeUnsignedTx
8698
:: forall era
8799
. Era era
88-
-> TxBodyContent CtxTx (LedgerEra era)
100+
-> TxBodyContent (LedgerEra era)
89101
-> Either String (UnsignedTx era)
90-
createUnsignedTx DijkstraEra _ = error "makeUnsignedTx: Dijkstra era not supported yet"
91-
createUnsignedTx era@ConwayEra bc = obtainCommonConstraints era $ do
102+
makeUnsignedTx DijkstraEra _ = error "makeUnsignedTx: Dijkstra era not supported yet"
103+
makeUnsignedTx era@ConwayEra bc = obtainCommonConstraints era $ do
92104
TxScriptWitnessRequirements languages scripts datums redeemers <-
93105
collectTxBodyScriptWitnessRequirements bc
94106

@@ -158,7 +170,7 @@ convTxIns :: [(TxIn, AnyWitness era)] -> Set L.TxIn
158170
convTxIns inputs =
159171
Set.fromList [toShelleyTxIn txin | (txin, _) <- inputs]
160172

161-
convCollateralTxIns :: TxBodyContent ctx era -> Set L.TxIn
173+
convCollateralTxIns :: TxBodyContent (LedgerEra era) -> Set L.TxIn
162174
convCollateralTxIns b =
163175
fromList (map toShelleyTxIn $ txInsCollateral b)
164176

@@ -245,7 +257,7 @@ toAuxiliaryData txMData ss' =
245257
eraSpecificLedgerTxBody
246258
:: Era era
247259
-> L.TxBody (LedgerEra era)
248-
-> TxBodyContent ctx (LedgerEra era)
260+
-> TxBodyContent (LedgerEra era)
249261
-> L.TxBody (LedgerEra era)
250262
eraSpecificLedgerTxBody era ledgerbody bc =
251263
body era
@@ -307,24 +319,25 @@ newtype TxValidityLowerBound = TxValidityLowerBound L.SlotNo
307319

308320
newtype TxExtraKeyWitnesses = TxExtraKeyWitnesses [Hash PaymentKey]
309321

310-
newtype TxWithdrawals era = TxWithdrawals [(StakeAddress, L.Coin, AnyWitness era)]
322+
newtype TxWithdrawals era = TxWithdrawals {unTxWithdrawals :: [(StakeAddress, L.Coin, AnyWitness era)]}
323+
deriving (Eq, Show)
311324

312325
newtype TxCertificates era
313326
= TxCertificates
314-
( OMap
315-
(Exp.Certificate era)
316-
(Maybe (StakeCredential, AnyWitness era))
317-
)
327+
{unTxCertificates :: OMap (Exp.Certificate era) (Maybe (StakeCredential, AnyWitness era))}
328+
deriving (Show, Eq)
318329

319330
-- This is incorrect. Only scripts can witness minting!
320331
newtype TxMintValue era
321332
= TxMintValue
322-
( Map
323-
PolicyId
324-
( PolicyAssets
325-
, AnyWitness era
326-
)
327-
)
333+
{ unTxMintValue
334+
:: Map
335+
PolicyId
336+
( PolicyAssets
337+
, AnyWitness era
338+
)
339+
}
340+
deriving (Eq, Show)
328341

329342
-- | Convert 'TxMintValue' to a more handy 'Value'.
330343
txMintValueToValue :: TxMintValue era -> Value
@@ -340,18 +353,20 @@ newtype TxProposalProcedures era
340353
(L.ProposalProcedure era)
341354
(Maybe (AnyWitness era))
342355
)
356+
deriving (Show, Eq)
343357

344358
data TxVotingProcedures era
345359
= TxVotingProcedures
346360
(L.VotingProcedures era)
347361
(Map L.Voter (AnyWitness era))
362+
deriving (Eq, Show)
348363

349-
data TxBodyContent ctx era
364+
data TxBodyContent era
350365
= TxBodyContent
351366
{ txIns :: [(TxIn, AnyWitness era)]
352367
, txInsCollateral :: [TxIn]
353368
, txInsReference :: TxInsReference era
354-
, txOuts :: [TxOut ctx era]
369+
, txOuts :: [TxOut CtxTx era]
355370
, txCollateral :: Maybe (TxCollateral era)
356371
, txFee :: L.Coin
357372
, txValidityLowerBound :: Maybe L.SlotNo
@@ -372,10 +387,36 @@ data TxBodyContent ctx era
372387
-- -- ^ Treasury donation to perform
373388
}
374389

390+
defaultTxBodyContent
391+
:: TxBodyContent (LedgerEra era)
392+
defaultTxBodyContent =
393+
TxBodyContent
394+
{ txIns = []
395+
, txInsCollateral = []
396+
, txInsReference = TxInsReference mempty Set.empty
397+
, txOuts = []
398+
, txCollateral = Nothing
399+
, txFee = 0
400+
, txValidityLowerBound = Nothing
401+
, txValidityUpperBound = Nothing
402+
, txMetadata = TxMetadata mempty
403+
, txAuxScripts = []
404+
, txExtraKeyWits = TxExtraKeyWitnesses []
405+
, txProtocolParams = Nothing
406+
, txWithdrawals = TxWithdrawals mempty
407+
, txCertificates = TxCertificates OMap.empty
408+
, txMintValue = TxMintValue mempty
409+
, txScriptValidity = ScriptValid
410+
, txProposalProcedures = Nothing
411+
, txVotingProcedures = Nothing
412+
, txCurrentTreasuryValue = Nothing
413+
, txTreasuryDonation = Nothing
414+
}
415+
375416
extractAllIndexedPlutusScriptWitnesses
376-
:: forall era ctx
417+
:: forall era
377418
. Era era
378-
-> TxBodyContent ctx (LedgerEra era)
419+
-> TxBodyContent (LedgerEra era)
379420
-> Either
380421
CBOR.DecoderError
381422
[AnyIndexedPlutusScriptWitness (LedgerEra era)]
@@ -506,7 +547,7 @@ extractWitnessableProposals (Just txPropProcedures) =
506547
collectTxBodyScriptWitnessRequirements
507548
:: forall era
508549
. IsEra era
509-
=> TxBodyContent CtxTx (LedgerEra era)
550+
=> TxBodyContent (LedgerEra era)
510551
-> Either
511552
String
512553
(TxScriptWitnessRequirements (LedgerEra era))
@@ -591,3 +632,29 @@ getDatums txInsRef txOutsFromTx = do
591632
L.TxDats $
592633
fromList $
593634
refInDatums <> txOutsDats
635+
636+
-- Getters and Setters
637+
638+
setTxIns :: [(TxIn, AnyWitness era)] -> TxBodyContent era -> TxBodyContent era
639+
setTxIns v txBodyContent = txBodyContent{txIns = v}
640+
641+
setTxFee :: L.Coin -> TxBodyContent era -> TxBodyContent era
642+
setTxFee v txBodyContent = txBodyContent{txFee = v}
643+
644+
setTxOuts :: [TxOut CtxTx era] -> TxBodyContent era -> TxBodyContent era
645+
setTxOuts v txBodyContent = txBodyContent{txOuts = v}
646+
647+
setTxMintValue :: TxMintValue era -> TxBodyContent era -> TxBodyContent era
648+
setTxMintValue v txBodyContent = txBodyContent{txMintValue = v}
649+
650+
setTxCertificates :: TxCertificates era -> TxBodyContent era -> TxBodyContent era
651+
setTxCertificates v txBodyContent = txBodyContent{txCertificates = v}
652+
653+
setTxWithdrawals :: TxWithdrawals era -> TxBodyContent era -> TxBodyContent era
654+
setTxWithdrawals v txBodyContent = txBodyContent{txWithdrawals = v}
655+
656+
setTxVotingProcedures :: TxVotingProcedures era -> TxBodyContent era -> TxBodyContent era
657+
setTxVotingProcedures v txBodyContent = txBodyContent{txVotingProcedures = Just v}
658+
659+
setTxProposalProcedures :: TxProposalProcedures era -> TxBodyContent era -> TxBodyContent era
660+
setTxProposalProcedures v txBodyContent = txBodyContent{txProposalProcedures = Just v}

0 commit comments

Comments
 (0)