/
Fees.hs
1404 lines (1235 loc) · 61.1 KB
/
Fees.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
-- | Fee calculation
--
module Cardano.Api.Fees (
-- * Transaction fees
transactionFee,
estimateTransactionFee,
evaluateTransactionFee,
estimateTransactionKeyWitnessCount,
-- * Script execution units
evaluateTransactionExecutionUnits,
ScriptExecutionError(..),
TransactionValidityError(..),
-- * Transaction balance
evaluateTransactionBalance,
-- * Automated transaction building
makeTransactionBodyAutoBalance,
BalancedTxBody(..),
TxBodyErrorAutoBalance(..),
-- * Minimum UTxO calculation
calculateMinimumUTxO,
MinimumUTxOError(..),
-- * Internal helpers
mapTxScriptWitnesses,
) where
import Control.Monad (forM_)
import qualified Data.Array as Array
import Data.Bifunctor (bimap, first)
import qualified Data.ByteString as BS
import Data.ByteString.Short (ShortByteString)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe, maybeToList)
import Data.Ratio
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as Text
import GHC.Records (HasField (..))
import Lens.Micro ((^.))
import Numeric.Natural
import Prettyprinter
import Prettyprinter.Render.String
import qualified Cardano.Binary as CBOR
import qualified Cardano.Ledger.BaseTypes as Ledger
import qualified Cardano.Chain.Common as Byron
import qualified Cardano.Ledger.Coin as Ledger
import Cardano.Ledger.Core (EraTx (sizeTxF))
import qualified Cardano.Ledger.Core as Ledger
import qualified Cardano.Ledger.Crypto as Ledger
import qualified Cardano.Ledger.Keys as Ledger
import Cardano.Ledger.Mary.Value (MaryValue)
import qualified Cardano.Ledger.Shelley.API.Wallet as Ledger (evaluateTransactionBalance,
evaluateTransactionFee)
import qualified Cardano.Ledger.Shelley.API.Wallet as Shelley
import Cardano.Ledger.Shelley.TxBody (ShelleyEraTxBody)
import qualified Cardano.Ledger.Alonzo as Alonzo
import qualified Cardano.Ledger.Alonzo.Language as Alonzo
import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
import qualified Cardano.Ledger.Alonzo.Scripts as L
import qualified Cardano.Ledger.Alonzo.Tools as Alonzo
import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
import qualified Cardano.Ledger.Alonzo.TxInfo as Alonzo
import qualified Cardano.Ledger.Alonzo.TxWits as Alonzo
import qualified Cardano.Ledger.Api.Scripts as L
import qualified Cardano.Ledger.Babbage as Babbage
import qualified Cardano.Ledger.Conway as Conway
import qualified Ouroboros.Consensus.HardFork.History as Consensus
import qualified PlutusLedgerApi.V1 as Plutus
import Cardano.Api.Address
import Cardano.Api.Certificate
import Cardano.Api.Eras
import Cardano.Api.Error
import Cardano.Api.NetworkId
import Cardano.Api.ProtocolParameters
import Cardano.Api.Query
import Cardano.Api.Script
import Cardano.Api.Tx
import Cardano.Api.TxBody
import Cardano.Api.Value
{- HLINT ignore "Redundant return" -}
-- ----------------------------------------------------------------------------
-- Transaction fees
--
-- | For a concrete fully-constructed transaction, determine the minimum fee
-- that it needs to pay.
--
-- This function is simple, but if you are doing input selection then you
-- probably want to consider estimateTransactionFee.
--
transactionFee :: forall era.
IsShelleyBasedEra era
=> Natural -- ^ The fixed tx fee
-> Natural -- ^ The tx fee per byte
-> Tx era
-> Lovelace
transactionFee txFeeFixed txFeePerByte tx =
let a = toInteger txFeePerByte
b = toInteger txFeeFixed
in case tx of
ShelleyTx _ tx' -> let x = obtainHasField shelleyBasedEra $ tx' ^. sizeTxF
in Lovelace (a * x + b)
--TODO: This can be made to work for Byron txs too. Do that: fill in this case
-- and remove the IsShelleyBasedEra constraint.
ByronTx _ -> case shelleyBasedEra :: ShelleyBasedEra ByronEra of {}
where
obtainHasField
:: ShelleyBasedEra era
-> ( EraTx (ShelleyLedgerEra era)
=> a)
-> a
obtainHasField ShelleyBasedEraShelley f = f
obtainHasField ShelleyBasedEraAllegra f = f
obtainHasField ShelleyBasedEraMary f = f
obtainHasField ShelleyBasedEraAlonzo f = f
obtainHasField ShelleyBasedEraBabbage f = f
obtainHasField ShelleyBasedEraConway f = f
{-# DEPRECATED transactionFee "Use 'evaluateTransactionFee' instead" #-}
--TODO: in the Byron case the per-byte is non-integral, would need different
-- parameters. e.g. a new data type for fee params, Byron vs Shelley
-- | This can estimate what the transaction fee will be, based on a starting
-- base transaction, plus the numbers of the additional components of the
-- transaction that may be added.
--
-- So for example with wallet coin selection, the base transaction should
-- contain all the things not subject to coin selection (such as script inputs,
-- metadata, withdrawals, certs etc)
--
estimateTransactionFee :: forall era.
IsShelleyBasedEra era
=> NetworkId
-> Natural -- ^ The fixed tx fee
-> Natural -- ^ The tx fee per byte
-> Tx era
-> Int -- ^ The number of extra UTxO transaction inputs
-> Int -- ^ The number of extra transaction outputs
-> Int -- ^ The number of extra Shelley key witnesses
-> Int -- ^ The number of extra Byron key witnesses
-> Lovelace
estimateTransactionFee nw txFeeFixed txFeePerByte (ShelleyTx era tx) =
let Lovelace baseFee = transactionFee txFeeFixed txFeePerByte (ShelleyTx era tx)
in \nInputs nOutputs nShelleyKeyWitnesses nByronKeyWitnesses ->
--TODO: this is fragile. Move something like this to the ledger and
-- make it robust, based on the txsize calculation.
let extraBytes :: Int
extraBytes = nInputs * sizeInput
+ nOutputs * sizeOutput
+ nByronKeyWitnesses * sizeByronKeyWitnesses
+ nShelleyKeyWitnesses * sizeShelleyKeyWitnesses
in Lovelace (baseFee + toInteger txFeePerByte * toInteger extraBytes)
where
sizeInput = smallArray + uint + hashObj
sizeOutput = smallArray + uint + address
sizeByronKeyWitnesses = smallArray + keyObj + sigObj + ccodeObj + attrsObj
sizeShelleyKeyWitnesses = smallArray + keyObj + sigObj
smallArray = 1
uint = 5
hashObj = 2 + hashLen
hashLen = 32
keyObj = 2 + keyLen
keyLen = 32
sigObj = 2 + sigLen
sigLen = 64
ccodeObj = 2 + ccodeLen
ccodeLen = 32
address = 2 + addrHeader + 2 * addrHashLen
addrHeader = 1
addrHashLen = 28
attrsObj = 2 + BS.length attributes
attributes = CBOR.serialize' $
Byron.mkAttributes Byron.AddrAttributes {
Byron.aaVKDerivationPath = Nothing,
Byron.aaNetworkMagic = toByronNetworkMagic nw
}
--TODO: This can be made to work for Byron txs too. Do that: fill in this case
-- and remove the IsShelleyBasedEra constraint.
estimateTransactionFee _ _ _ (ByronTx _) =
case shelleyBasedEra :: ShelleyBasedEra era of {}
--TODO: also deprecate estimateTransactionFee:
--{-# DEPRECATED estimateTransactionFee "Use 'evaluateTransactionFee' instead" #-}
-- | Compute the transaction fee for a proposed transaction, with the
-- assumption that there will be the given number of key witnesses (i.e.
-- signatures).
--
-- TODO: we need separate args for Shelley vs Byron key sigs
--
evaluateTransactionFee :: forall era.
IsShelleyBasedEra era
=> BundledProtocolParameters era
-> TxBody era
-> Word -- ^ The number of Shelley key witnesses
-> Word -- ^ The number of Byron key witnesses
-> Lovelace
evaluateTransactionFee _ _ _ byronwitcount | byronwitcount > 0 =
error "evaluateTransactionFee: TODO support Byron key witnesses"
evaluateTransactionFee bpparams txbody keywitcount _byronwitcount =
case makeSignedTransaction [] txbody of
ByronTx{} -> case shelleyBasedEra :: ShelleyBasedEra era of {}
--TODO: we could actually support Byron here, it'd be different but simpler
ShelleyTx era tx -> withLedgerConstraints era (evalShelleyBasedEra tx)
where
evalShelleyBasedEra :: forall ledgerera.
ShelleyLedgerEra era ~ ledgerera
=> ShelleyBasedEra era
-> Ledger.Tx ledgerera
-> Lovelace
evalShelleyBasedEra tx =
fromShelleyLovelace $
Ledger.evaluateTransactionFee
(unbundleLedgerShelleyBasedProtocolParams shelleyBasedEra bpparams)
tx
keywitcount
-- Conjure up all the necessary class instances and evidence
withLedgerConstraints
:: ShelleyLedgerEra era ~ ledgerera
=> ShelleyBasedEra era
-> ( () -- Ledger.CLI ledgerera
=> a)
-> a
withLedgerConstraints ShelleyBasedEraShelley f = f
withLedgerConstraints ShelleyBasedEraAllegra f = f
withLedgerConstraints ShelleyBasedEraMary f = f
withLedgerConstraints ShelleyBasedEraAlonzo f = f
withLedgerConstraints ShelleyBasedEraBabbage f = f
withLedgerConstraints ShelleyBasedEraConway f = f
-- | Give an approximate count of the number of key witnesses (i.e. signatures)
-- a transaction will need.
--
-- This is an estimate not a precise count in that it can over-estimate: it
-- makes conservative assumptions such as all inputs are from distinct
-- addresses, but in principle multiple inputs can use the same address and we
-- only need a witness per address.
--
-- Similarly there can be overlap between the regular and collateral inputs,
-- but we conservatively assume they are distinct.
--
-- TODO: it is worth us considering a more precise count that relies on the
-- UTxO to resolve which inputs are for distinct addresses, and also to count
-- the number of Shelley vs Byron style witnesses.
--
estimateTransactionKeyWitnessCount :: TxBodyContent BuildTx era -> Word
estimateTransactionKeyWitnessCount TxBodyContent {
txIns,
txInsCollateral,
txExtraKeyWits,
txWithdrawals,
txCertificates,
txUpdateProposal
} =
fromIntegral $
length [ () | (_txin, BuildTxWith KeyWitness{}) <- txIns ]
+ case txInsCollateral of
TxInsCollateral _ txins
-> length txins
_ -> 0
+ case txExtraKeyWits of
TxExtraKeyWitnesses _ khs
-> length khs
_ -> 0
+ case txWithdrawals of
TxWithdrawals _ withdrawals
-> length [ () | (_, _, BuildTxWith KeyWitness{}) <- withdrawals ]
_ -> 0
+ case txCertificates of
TxCertificates _ _ (BuildTxWith witnesses)
-> length [ () | KeyWitness{} <- Map.elems witnesses ]
_ -> 0
+ case txUpdateProposal of
TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _)
-> Map.size updatePerGenesisKey
_ -> 0
-- ----------------------------------------------------------------------------
-- Script execution units
--
type PlutusScriptBytes = ShortByteString
type ResolvablePointers =
Map
Alonzo.RdmrPtr
( Alonzo.ScriptPurpose Ledger.StandardCrypto
, Maybe (PlutusScriptBytes, Alonzo.Language)
, Ledger.ScriptHash Ledger.StandardCrypto
)
-- | The different possible reasons that executing a script can fail,
-- as reported by 'evaluateTransactionExecutionUnits'.
--
-- The first three of these are about failures before we even get to execute
-- the script, and two are the result of execution.
--
data ScriptExecutionError =
-- | The script depends on a 'TxIn' that has not been provided in the
-- given 'UTxO' subset. The given 'UTxO' must cover all the inputs
-- the transaction references.
ScriptErrorMissingTxIn TxIn
-- | The 'TxIn' the script is spending does not have a 'ScriptDatum'.
-- All inputs guarded by Plutus scripts need to have been created with
-- a 'ScriptDatum'.
| ScriptErrorTxInWithoutDatum TxIn
-- | The 'ScriptDatum' provided does not match the one from the 'UTxO'.
-- This means the wrong 'ScriptDatum' value has been provided.
--
| ScriptErrorWrongDatum (Hash ScriptData)
-- | The script evaluation failed. This usually means it evaluated to an
-- error value. This is not a case of running out of execution units
-- (which is not possible for 'evaluateTransactionExecutionUnits' since
-- the whole point of it is to discover how many execution units are
-- needed).
--
| ScriptErrorEvaluationFailed Plutus.EvaluationError [Text.Text]
-- | The execution units overflowed a 64bit word. Congratulations if
-- you encounter this error. With the current style of cost model this
-- would need a script to run for over 7 months, which is somewhat more
-- than the expected maximum of a few milliseconds.
--
| ScriptErrorExecutionUnitsOverflow
-- | An attempt was made to spend a key witnessed tx input
-- with a script witness.
| ScriptErrorNotPlutusWitnessedTxIn ScriptWitnessIndex ScriptHash
-- | The redeemer pointer points to a script hash that does not exist
-- in the transaction nor in the UTxO as a reference script"
| ScriptErrorRedeemerPointsToUnknownScriptHash ScriptWitnessIndex
-- | A redeemer pointer points to a script that does not exist.
| ScriptErrorMissingScript
Alonzo.RdmrPtr -- The invalid pointer
ResolvablePointers -- A mapping a pointers that are possible to resolve
-- | A cost model was missing for a language which was used.
| ScriptErrorMissingCostModel Alonzo.Language
deriving Show
instance Error ScriptExecutionError where
displayError (ScriptErrorMissingTxIn txin) =
"The supplied UTxO is missing the txin " ++ Text.unpack (renderTxIn txin)
displayError (ScriptErrorTxInWithoutDatum txin) =
"The Plutus script witness for the txin does not have a script datum "
++ "(according to the UTxO). The txin in question is "
++ Text.unpack (renderTxIn txin)
displayError (ScriptErrorWrongDatum dh) =
"The Plutus script witness has the wrong datum (according to the UTxO). "
++ "The expected datum value has hash " ++ show dh
displayError (ScriptErrorEvaluationFailed evalErr logs) =
"The Plutus script evaluation failed: " ++ pp evalErr ++
"\nScript debugging logs: " <> mconcat (map (\t -> Text.unpack $ t `Text.append` "\n") logs)
where
pp :: Pretty p => p -> String
pp = renderString
. layoutPretty defaultLayoutOptions
. pretty
displayError ScriptErrorExecutionUnitsOverflow =
"The execution units required by this Plutus script overflows a 64bit "
++ "word. In a properly configured chain this should be practically "
++ "impossible. So this probably indicates a chain configuration problem, "
++ "perhaps with the values in the cost model."
displayError (ScriptErrorNotPlutusWitnessedTxIn scriptWitness scriptHash) =
renderScriptWitnessIndex scriptWitness <> " is not a Plutus script "
<> "witnessed tx input and cannot be spent using a Plutus script witness."
<> "The script hash is " <> show scriptHash <> "."
displayError (ScriptErrorRedeemerPointsToUnknownScriptHash scriptWitness) =
renderScriptWitnessIndex scriptWitness <> " points to a script hash "
<> "that is not known."
displayError (ScriptErrorMissingScript rdmrPtr resolveable) =
"The redeemer pointer: " <> show rdmrPtr <> " points to a Plutus "
<> "script that does not exist.\n" <>
"The pointers that can be resolved are: " <> show resolveable
displayError (ScriptErrorMissingCostModel language) =
"No cost model was found for language " <> show language
data TransactionValidityError =
-- | The transaction validity interval is too far into the future.
--
-- Transactions with Plutus scripts need to have a validity interval that is
-- not so far in the future that we cannot reliably determine the UTC time
-- corresponding to the validity interval expressed in slot numbers.
--
-- This is because the Plutus scripts get given the transaction validity
-- interval in UTC time, so that they are not sensitive to slot lengths.
--
-- If either end of the validity interval is beyond the so called \"time
-- horizon\" then the consensus algorithm is not able to reliably determine
-- the relationship between slots and time. This is this situation in which
-- this error is reported. For the Cardano mainnet the time horizon is 36
-- hours beyond the current time. This effectively means we cannot submit
-- check or submit transactions that use Plutus scripts that have the end
-- of their validity interval more than 36 hours into the future.
TransactionValidityIntervalError Consensus.PastHorizonException
| TransactionValidityTranslationError (Alonzo.TranslationError Ledger.StandardCrypto)
| TransactionValidityCostModelError (Map AnyPlutusScriptVersion CostModel) String
deriving instance Show TransactionValidityError
instance Error TransactionValidityError where
displayError (TransactionValidityIntervalError pastTimeHorizon) =
"The transaction validity interval is too far in the future. "
++ "For this network it must not be more than "
++ show (timeHorizonSlots pastTimeHorizon)
++ "slots ahead of the current time slot. "
++ "(Transactions with Plutus scripts must have validity intervals that "
++ "are close enough in the future that we can reliably turn the slot "
++ "numbers into UTC wall clock times.)"
where
timeHorizonSlots :: Consensus.PastHorizonException -> Word
timeHorizonSlots Consensus.PastHorizon{Consensus.pastHorizonSummary}
| eraSummaries@(_:_) <- pastHorizonSummary
, Consensus.StandardSafeZone slots <-
(Consensus.eraSafeZone . Consensus.eraParams . last) eraSummaries
= fromIntegral slots
| otherwise
= 0 -- This should be impossible.
displayError (TransactionValidityTranslationError errmsg) =
"Error translating the transaction context: " <> show errmsg
displayError (TransactionValidityCostModelError cModels err) =
"An error occurred while converting from the cardano-api cost" <>
" models to the cardano-ledger cost models. Error: " <> err <>
" Cost models: " <> show cModels
-- | Compute the 'ExecutionUnits' needed for each script in the transaction.
--
-- This works by running all the scripts and counting how many execution units
-- are actually used.
--
evaluateTransactionExecutionUnits
:: forall era.
SystemStart
-> LedgerEpochInfo
-> BundledProtocolParameters era
-> UTxO era
-> TxBody era
-> Either TransactionValidityError
(Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evaluateTransactionExecutionUnits systemstart epochInfo bpp utxo txbody =
case makeSignedTransaction [] txbody of
ByronTx {} -> evalPreAlonzo
ShelleyTx sbe tx' ->
case sbe of
ShelleyBasedEraShelley -> evalPreAlonzo
ShelleyBasedEraAllegra -> evalPreAlonzo
ShelleyBasedEraMary -> evalPreAlonzo
ShelleyBasedEraAlonzo -> evalAlonzo sbe tx'
ShelleyBasedEraBabbage ->
case collateralSupportedInEra $ shelleyBasedToCardanoEra sbe of
Just supp -> obtainHasFieldConstraint supp $ evalBabbage sbe tx'
Nothing -> return mempty
ShelleyBasedEraConway ->
case collateralSupportedInEra $ shelleyBasedToCardanoEra sbe of
Just supp -> obtainHasFieldConstraint supp $ evalConway sbe tx'
Nothing -> return mempty
ShelleyBasedEraConway ->
case collateralSupportedInEra $ shelleyBasedToCardanoEra era of
Just supp -> obtainHasFieldConstraint supp $ evalConway era tx'
Nothing -> return mempty
where
LedgerEpochInfo ledgerEpochInfo = epochInfo
-- | Pre-Alonzo eras do not support languages with execution unit accounting.
evalPreAlonzo :: Either TransactionValidityError
(Map ScriptWitnessIndex
(Either ScriptExecutionError ExecutionUnits))
evalPreAlonzo = Right Map.empty
evalAlonzo :: forall ledgerera.
ShelleyLedgerEra era ~ ledgerera
=> ledgerera ~ Alonzo.AlonzoEra Ledger.StandardCrypto
=> HasField "_maxTxExUnits" (Ledger.PParams ledgerera) Alonzo.ExUnits
=> HasField"_protocolVersion" (Ledger.PParams ledgerera) Ledger.ProtVer
=> LedgerEraConstraints ledgerera
=> ShelleyBasedEra era
-> Ledger.Tx ledgerera
-> Either TransactionValidityError
(Map ScriptWitnessIndex
(Either ScriptExecutionError ExecutionUnits))
evalAlonzo era tx = do
cModelArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp))
case Alonzo.evaluateTransactionExecutionUnits
(unbundleLedgerShelleyBasedProtocolParams era bpp)
tx
(toLedgerUTxO era utxo)
ledgerEpochInfo
systemstart
cModelArray
of Left err -> Left (TransactionValidityTranslationError err)
Right exmap -> Right (fromLedgerScriptExUnitsMap exmap)
evalBabbage :: forall ledgerera.
ShelleyLedgerEra era ~ ledgerera
=> ledgerera ~ Babbage.BabbageEra Ledger.StandardCrypto
=> HasField "_maxTxExUnits" (Ledger.PParams ledgerera) Alonzo.ExUnits
=> HasField"_protocolVersion" (Ledger.PParams ledgerera) Ledger.ProtVer
=> ShelleyBasedEra era
-> Ledger.Tx ledgerera
-> Either TransactionValidityError
(Map ScriptWitnessIndex
(Either ScriptExecutionError ExecutionUnits))
evalBabbage era tx = do
costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels (unbundleProtocolParams bpp))
case Alonzo.evaluateTransactionExecutionUnits
(unbundleLedgerShelleyBasedProtocolParams era bpp)
tx
(toLedgerUTxO era utxo)
ledgerEpochInfo
systemstart
costModelsArray
of Left err -> Left (TransactionValidityTranslationError err)
Right exmap -> Right (fromLedgerScriptExUnitsMap exmap)
evalConway :: forall ledgerera.
ShelleyLedgerEra era ~ ledgerera
=> ledgerera ~ Conway.ConwayEra Ledger.StandardCrypto
=> HasField "_maxTxExUnits" (Ledger.PParams ledgerera) Alonzo.ExUnits
=> HasField"_protocolVersion" (Ledger.PParams ledgerera) Ledger.ProtVer
=> ShelleyBasedEra era
-> Ledger.Tx ledgerera
-> Either TransactionValidityError
(Map ScriptWitnessIndex
(Either ScriptExecutionError ExecutionUnits))
evalConway era tx = do
costModelsArray <- toAlonzoCostModelsArray (protocolParamCostModels pparams)
case Alonzo.evaluateTransactionExecutionUnits
(toLedgerPParams era pparams)
tx
(toLedgerUTxO era utxo)
ledgerEpochInfo
systemstart
costModelsArray
of Left err -> Left (TransactionValidityTranslationError err)
Right exmap -> Right (fromLedgerScriptExUnitsMap exmap)
toAlonzoCostModelsArray
:: Map AnyPlutusScriptVersion CostModel
-> Either TransactionValidityError (Array.Array Alonzo.Language Alonzo.CostModel)
toAlonzoCostModelsArray costmodels = do
Alonzo.CostModels cModels <- first (TransactionValidityCostModelError costmodels) $ toAlonzoCostModels costmodels
return $ Array.array (minBound, maxBound) (Map.toList cModels)
fromLedgerScriptExUnitsMap
:: Map Alonzo.RdmrPtr (Either (Alonzo.TransactionScriptFailure Ledger.StandardCrypto)
Alonzo.ExUnits)
-> Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
fromLedgerScriptExUnitsMap exmap =
Map.fromList
[ (fromAlonzoRdmrPtr rdmrptr,
bimap fromAlonzoScriptExecutionError fromAlonzoExUnits exunitsOrFailure)
| (rdmrptr, exunitsOrFailure) <- Map.toList exmap ]
fromAlonzoScriptExecutionError :: Alonzo.TransactionScriptFailure Ledger.StandardCrypto
-> ScriptExecutionError
fromAlonzoScriptExecutionError failure =
case failure of
L.UnknownTxIn txin -> ScriptErrorMissingTxIn txin'
where txin' = fromShelleyTxIn txin
L.InvalidTxIn txin -> ScriptErrorTxInWithoutDatum txin'
where txin' = fromShelleyTxIn txin
L.MissingDatum dh -> ScriptErrorWrongDatum (ScriptDataHash dh)
L.ValidationFailedV1 err logs -> ScriptErrorEvaluationFailed err logs
L.ValidationFailedV2 err logs -> ScriptErrorEvaluationFailed err logs
L.IncompatibleBudget _ -> ScriptErrorExecutionUnitsOverflow
-- This is only possible for spending scripts and occurs when
-- we attempt to spend a key witnessed tx input with a Plutus
-- script witness.
L.RedeemerNotNeeded rdmrPtr scriptHash ->
ScriptErrorNotPlutusWitnessedTxIn
(fromAlonzoRdmrPtr rdmrPtr)
(fromShelleyScriptHash scriptHash)
L.RedeemerPointsToUnknownScriptHash rdmrPtr ->
ScriptErrorRedeemerPointsToUnknownScriptHash $ fromAlonzoRdmrPtr rdmrPtr
-- This should not occur while using cardano-cli because we zip together
-- the Plutus script and the use site (txin, certificate etc). Therefore
-- the redeemer pointer will always point to a Plutus script.
L.MissingScript rdmrPtr resolveable -> ScriptErrorMissingScript rdmrPtr resolveable
L.NoCostModelInLedgerState l -> ScriptErrorMissingCostModel l
obtainHasFieldConstraint
:: ShelleyLedgerEra era ~ ledgerera
=> CollateralSupportedInEra era
-> (HasField "_maxTxExUnits" (Ledger.PParams ledgerera) Alonzo.ExUnits => a) -> a
obtainHasFieldConstraint CollateralInAlonzoEra f = f
obtainHasFieldConstraint CollateralInBabbageEra f = f
obtainHasFieldConstraint CollateralInConwayEra f = f
-- ----------------------------------------------------------------------------
-- Transaction balance
--
-- | Compute the total balance of the proposed transaction. Ultimately a valid
-- transaction must be fully balanced: that is have a total value of zero.
--
-- Finding the (non-zero) balance of partially constructed transaction is
-- useful for adjusting a transaction to be fully balanced.
--
evaluateTransactionBalance :: forall era.
IsShelleyBasedEra era
=> BundledProtocolParameters era
-> Set PoolId
-> UTxO era
-> TxBody era
-> TxOutValue era
evaluateTransactionBalance _ _ _ (ByronTxBody _) =
case shelleyBasedEra :: ShelleyBasedEra era of {}
--TODO: we could actually support Byron here, it'd be different but simpler
evaluateTransactionBalance bpp poolids utxo
(ShelleyTxBody era txbody _ _ _ _) =
withLedgerConstraints
era
(getShelleyEraTxBodyConstraint era evalAdaOnly)
(getShelleyEraTxBodyConstraint era evalMultiAsset)
where
getShelleyEraTxBodyConstraint
:: forall era' a.
ShelleyBasedEra era'
-> (ShelleyEraTxBody (ShelleyLedgerEra era') => a)
-> a
getShelleyEraTxBodyConstraint ShelleyBasedEraShelley x = x
getShelleyEraTxBodyConstraint ShelleyBasedEraMary x = x
getShelleyEraTxBodyConstraint ShelleyBasedEraAllegra x = x
getShelleyEraTxBodyConstraint ShelleyBasedEraAlonzo x = x
getShelleyEraTxBodyConstraint ShelleyBasedEraBabbage x = x
getShelleyEraTxBodyConstraint ShelleyBasedEraConway x = x
isNewPool :: Ledger.KeyHash Ledger.StakePool Ledger.StandardCrypto -> Bool
isNewPool kh = StakePoolKeyHash kh `Set.notMember` poolids
evalMultiAsset :: forall ledgerera.
ShelleyLedgerEra era ~ ledgerera
=> ShelleyEraTxBody ledgerera
=> LedgerEraConstraints ledgerera
=> LedgerMultiAssetConstraints ledgerera
=> MultiAssetSupportedInEra era
-> TxOutValue era
evalMultiAsset evidence =
TxOutValue evidence . fromMaryValue $
Ledger.evaluateTransactionBalance
(unbundleLedgerShelleyBasedProtocolParams era bpp)
(toLedgerUTxO era utxo)
isNewPool
txbody
evalAdaOnly :: forall ledgerera.
ShelleyLedgerEra era ~ ledgerera
=> ShelleyEraTxBody ledgerera
=> LedgerEraConstraints ledgerera
=> LedgerAdaOnlyConstraints ledgerera
=> OnlyAdaSupportedInEra era
-> TxOutValue era
evalAdaOnly evidence =
TxOutAdaOnly evidence . fromShelleyLovelace
$ Ledger.evaluateTransactionBalance
(unbundleLedgerShelleyBasedProtocolParams era bpp)
(toLedgerUTxO era utxo)
isNewPool
txbody
-- Conjur up all the necessary class instances and evidence
withLedgerConstraints
:: ShelleyLedgerEra era ~ ledgerera
=> ShelleyBasedEra era
-> ( LedgerEraConstraints ledgerera
=> LedgerAdaOnlyConstraints ledgerera
=> LedgerPParamsConstraints ledgerera
=> LedgerTxBodyConstraints ledgerera
=> OnlyAdaSupportedInEra era
-> a)
-> ( LedgerEraConstraints ledgerera
=> LedgerMultiAssetConstraints ledgerera
=> LedgerPParamsConstraints ledgerera
=> LedgerTxBodyConstraints ledgerera
=> MultiAssetSupportedInEra era
-> a)
-> a
withLedgerConstraints ShelleyBasedEraShelley f _ = f AdaOnlyInShelleyEra
withLedgerConstraints ShelleyBasedEraAllegra f _ = f AdaOnlyInAllegraEra
withLedgerConstraints ShelleyBasedEraMary _ f = f MultiAssetInMaryEra
withLedgerConstraints ShelleyBasedEraAlonzo _ f = f MultiAssetInAlonzoEra
withLedgerConstraints ShelleyBasedEraBabbage _ f = f MultiAssetInBabbageEra
withLedgerConstraints ShelleyBasedEraConway _ f = f MultiAssetInConwayEra
type LedgerEraConstraints ledgerera =
( Ledger.EraCrypto ledgerera ~ Ledger.StandardCrypto
-- , Ledger.CLI ledgerera
)
type LedgerAdaOnlyConstraints ledgerera =
Ledger.Value ledgerera ~ Ledger.Coin
type LedgerMultiAssetConstraints ledgerera =
( Ledger.Value ledgerera ~ MaryValue Ledger.StandardCrypto
)
type LedgerPParamsConstraints ledgerera =
( HasField "_minfeeA" (Ledger.PParams ledgerera) Natural
, HasField "_minfeeB" (Ledger.PParams ledgerera) Natural
, HasField "_keyDeposit" (Ledger.PParams ledgerera) Ledger.Coin
, HasField "_poolDeposit" (Ledger.PParams ledgerera) Ledger.Coin
)
type LedgerTxBodyConstraints ledgerera =
( Ledger.EraTx ledgerera
)
-- ----------------------------------------------------------------------------
-- Automated transaction building
--
-- | The possible errors that can arise from 'makeTransactionBodyAutoBalance'.
--
data TxBodyErrorAutoBalance =
-- | The same errors that can arise from 'makeTransactionBody'.
TxBodyError TxBodyError
-- | One or more of the scripts fails to execute correctly.
| TxBodyScriptExecutionError [(ScriptWitnessIndex, ScriptExecutionError)]
-- | One or more of the scripts were expected to fail validation, but none did.
| TxBodyScriptBadScriptValidity
-- | The balance of the non-ada assets is not zero. The 'Value' here is
-- that residual non-zero balance. The 'makeTransactionBodyAutoBalance'
-- function only automatically balances ada, not other assets.
| TxBodyErrorAssetBalanceWrong Value
-- | There is not enough ada to cover both the outputs and the fees.
-- The transaction should be changed to provide more input ada, or
-- otherwise adjusted to need less (e.g. outputs, script etc).
--
| TxBodyErrorAdaBalanceNegative Lovelace
-- | There is enough ada to cover both the outputs and the fees, but the
-- resulting change is too small: it is under the minimum value for
-- new UTxO entries. The transaction should be changed to provide more
-- input ada.
--
| TxBodyErrorAdaBalanceTooSmall
-- ^ Offending TxOut
TxOutInAnyEra
-- ^ Minimum UTxO
Lovelace
-- ^ Tx balance
Lovelace
-- | 'makeTransactionBodyAutoBalance' does not yet support the Byron era.
| TxBodyErrorByronEraNotSupported
-- | The 'ProtocolParameters' must provide the value for the min utxo
-- parameter, for eras that use this parameter.
| TxBodyErrorMissingParamMinUTxO
-- | The transaction validity interval is too far into the future.
-- See 'TransactionValidityIntervalError' for details.
| TxBodyErrorValidityInterval TransactionValidityError
-- | The minimum spendable UTxO threshold has not been met.
| TxBodyErrorMinUTxONotMet
-- ^ Offending TxOut
TxOutInAnyEra
-- ^ Minimum UTxO
Lovelace
| TxBodyErrorMinUTxOMissingPParams MinimumUTxOError
| TxBodyErrorNonAdaAssetsUnbalanced Value
| TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap
ScriptWitnessIndex
(Map ScriptWitnessIndex ExecutionUnits)
deriving Show
instance Error TxBodyErrorAutoBalance where
displayError (TxBodyError err) = displayError err
displayError (TxBodyScriptExecutionError failures) =
"The following scripts have execution failures:\n"
++ unlines [ "the script for " ++ renderScriptWitnessIndex index
++ " failed with: " ++ "\n" ++ displayError failure
| (index, failure) <- failures ]
displayError TxBodyScriptBadScriptValidity =
"One or more of the scripts were expected to fail validation, but none did."
displayError (TxBodyErrorAssetBalanceWrong _value) =
"The transaction does not correctly balance in its non-ada assets. "
++ "The balance between inputs and outputs should sum to zero. "
++ "The actual balance is: "
++ "TODO: move the Value renderer and parser from the CLI into the API and use them here"
-- TODO: do this ^^
displayError (TxBodyErrorAdaBalanceNegative lovelace) =
"The transaction does not balance in its use of ada. The net balance "
++ "of the transaction is negative: " ++ show lovelace ++ " lovelace. "
++ "The usual solution is to provide more inputs, or inputs with more ada."
displayError (TxBodyErrorAdaBalanceTooSmall changeOutput minUTxO balance) =
"The transaction does balance in its use of ada, however the net "
++ "balance does not meet the minimum UTxO threshold. \n"
++ "Balance: " ++ show balance ++ "\n"
++ "Offending output (change output): " ++ Text.unpack (prettyRenderTxOut changeOutput) ++ "\n"
++ "Minimum UTxO threshold: " ++ show minUTxO ++ "\n"
++ "The usual solution is to provide more inputs, or inputs with more ada to "
++ "meet the minimum UTxO threshold"
displayError TxBodyErrorByronEraNotSupported =
"The Byron era is not yet supported by makeTransactionBodyAutoBalance"
displayError TxBodyErrorMissingParamMinUTxO =
"The minUTxOValue protocol parameter is required but missing"
displayError (TxBodyErrorValidityInterval err) =
displayError err
displayError (TxBodyErrorMinUTxONotMet txout minUTxO) =
"Minimum UTxO threshold not met for tx output: " <> Text.unpack (prettyRenderTxOut txout) <> "\n"
<> "Minimum required UTxO: " <> show minUTxO
displayError (TxBodyErrorNonAdaAssetsUnbalanced val) =
"Non-Ada assets are unbalanced: " <> Text.unpack (renderValue val)
displayError (TxBodyErrorMinUTxOMissingPParams err) = displayError err
displayError (TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap sIndex eUnitsMap) =
"ScriptWitnessIndex (redeemer pointer): " <> show sIndex <> " is missing from the execution "
++ "units (redeemer pointer) map: " <> show eUnitsMap
handleExUnitsErrors ::
ScriptValidity -- ^ Mark script as expected to pass or fail validation
-> Map ScriptWitnessIndex ScriptExecutionError
-> Map ScriptWitnessIndex ExecutionUnits
-> Either TxBodyErrorAutoBalance (Map ScriptWitnessIndex ExecutionUnits)
handleExUnitsErrors ScriptValid failuresMap exUnitsMap =
if null failures
then Right exUnitsMap
else Left (TxBodyScriptExecutionError failures)
where failures :: [(ScriptWitnessIndex, ScriptExecutionError)]
failures = Map.toList failuresMap
handleExUnitsErrors ScriptInvalid failuresMap exUnitsMap
| null failuresMap = Left TxBodyScriptBadScriptValidity
| otherwise = Right $ Map.map (\_ -> ExecutionUnits 0 0) failuresMap <> exUnitsMap
data BalancedTxBody era
= BalancedTxBody
(TxBodyContent BuildTx era)
(TxBody era)
(TxOut CtxTx era) -- ^ Transaction balance (change output)
Lovelace -- ^ Estimated transaction fee
-- | This is much like 'makeTransactionBody' but with greater automation to
-- calculate suitable values for several things.
--
-- In particular:
--
-- * It calculates the correct script 'ExecutionUnits' (ignoring the provided
-- values, which can thus be zero).
--
-- * It calculates the transaction fees, based on the script 'ExecutionUnits',
-- the current 'ProtocolParameters', and an estimate of the number of
-- key witnesses (i.e. signatures). There is an override for the number of
-- key witnesses.
--
-- * It accepts a change address, calculates the balance of the transaction
-- and puts the excess change into the change output.
--
-- * It also checks that the balance is positive and the change is above the
-- minimum threshold.
--
-- To do this it needs more information than 'makeTransactionBody', all of
-- which can be queried from a local node.
--
makeTransactionBodyAutoBalance
:: forall era.
IsShelleyBasedEra era
=> SystemStart
-> LedgerEpochInfo
-> ProtocolParameters
-> Set PoolId -- ^ The set of registered stake pools
-> UTxO era -- ^ Just the transaction inputs, not the entire 'UTxO'.
-> TxBodyContent BuildTx era
-> AddressInEra era -- ^ Change address
-> Maybe Word -- ^ Override key witnesses
-> Either TxBodyErrorAutoBalance (BalancedTxBody era)
makeTransactionBodyAutoBalance systemstart history pparams
poolids utxo txbodycontent changeaddr mnkeys = do
-- Our strategy is to:
-- 1. evaluate all the scripts to get the exec units, update with ex units
-- 2. figure out the overall min fees
-- 3. update tx with fees
-- 4. balance the transaction and update tx change output
txbody0 <-
first TxBodyError $ createAndValidateTransactionBody txbodycontent
{ txOuts = txOuts txbodycontent ++
[TxOut changeaddr (lovelaceToTxOutValue 0) TxOutDatumNone ReferenceScriptNone]
--TODO: think about the size of the change output
-- 1,2,4 or 8 bytes?
}
exUnitsMap <- first TxBodyErrorValidityInterval $
evaluateTransactionExecutionUnits
systemstart history
bpparams
utxo
txbody0
exUnitsMap' <-
case Map.mapEither id exUnitsMap of
(failures, exUnitsMap') ->
handleExUnitsErrors
(txScriptValidityToScriptValidity (txScriptValidity txbodycontent))
failures
exUnitsMap'
txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent
explicitTxFees <- first (const TxBodyErrorByronEraNotSupported) $
txFeesExplicitInEra era'