-
Notifications
You must be signed in to change notification settings - Fork 16
/
Fees.hs
1122 lines (1004 loc) · 48.8 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 FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
-- | Fee calculation
--
module Cardano.Api.Fees (
-- * Transaction fees
evaluateTransactionFee,
calculateMinTxFee,
estimateTransactionKeyWitnessCount,
-- * Script execution units
evaluateTransactionExecutionUnits,
ScriptExecutionError(..),
TransactionValidityError(..),
-- * Transaction balance
evaluateTransactionBalance,
-- * Automated transaction building
makeTransactionBodyAutoBalance,
BalancedTxBody(..),
TxBodyErrorAutoBalance(..),
-- * Minimum UTxO calculation
calculateMinimumUTxO,
-- * Internal helpers
mapTxScriptWitnesses,
ResolvablePointers(..),
) where
import Cardano.Api.Address
import Cardano.Api.Certificate
import Cardano.Api.Eon.AlonzoEraOnwards
import Cardano.Api.Eon.BabbageEraOnwards
import Cardano.Api.Eon.MaryEraOnwards
import Cardano.Api.Eon.ShelleyBasedEra
import Cardano.Api.Eras.Case
import Cardano.Api.Eras.Core
import Cardano.Api.Error
import qualified Cardano.Api.Ledger.Lens as A
import Cardano.Api.Pretty
import Cardano.Api.ProtocolParameters
import Cardano.Api.Query
import Cardano.Api.Script
import Cardano.Api.Tx.Body
import Cardano.Api.Tx.Sign
import Cardano.Api.Value
import qualified Cardano.Ledger.Alonzo.Core as Ledger
import qualified Cardano.Ledger.Alonzo.Plutus.Context as Plutus
import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
import qualified Cardano.Ledger.Api as L
import qualified Cardano.Ledger.Coin as L
import Cardano.Ledger.Credential as Ledger (Credential)
import qualified Cardano.Ledger.Crypto as Ledger
import qualified Cardano.Ledger.Keys as Ledger
import qualified Cardano.Ledger.Plutus.Language as Plutus
import qualified Ouroboros.Consensus.HardFork.History as Consensus
import qualified PlutusLedgerApi.V1 as Plutus
import Control.Monad (forM_)
import Data.Bifunctor (bimap, first)
import Data.ByteString.Short (ShortByteString)
import Data.Function ((&))
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 Lens.Micro ((.~), (^.))
{- HLINT ignore "Redundant return" -}
--- ----------------------------------------------------------------------------
--- Transaction fees
---
-- | Compute the transaction fee for a proposed transaction, with the
-- assumption that there will be the given number of key witnesses (i.e.
-- signatures).
--
-- Use 'calculateMinTxFee' if possible as that function is more accurate.
evaluateTransactionFee :: forall era. ()
=> ShelleyBasedEra era
-> Ledger.PParams (ShelleyLedgerEra era)
-> TxBody era
-> Word -- ^ The number of Shelley key witnesses
-> Word -- ^ The number of Byron key witnesses
-> Int -- ^ Reference script size in bytes
-> L.Coin
evaluateTransactionFee sbe pp txbody keywitcount byronwitcount refScriptsSize =
shelleyBasedEraConstraints sbe $
case makeSignedTransaction' (shelleyBasedToCardanoEra sbe) [] txbody of
ShelleyTx _ tx ->
L.estimateMinFeeTx pp tx (fromIntegral keywitcount) (fromIntegral byronwitcount) refScriptsSize
-- | Estimate minimum transaction fee for a proposed transaction by looking
-- into the transaction and figuring out how many and what kind of key
-- witnesses this transaction needs.
--
-- It requires access to the portion of the `UTxO` that is relevant for this
-- transaction in order to lookup any txins included in the transaction.
--
-- The only type of witnesses that it cannot figure out reliably is the
-- witnesses needed for satisfying native scripts included in the transaction.
--
-- For this reason number of witnesses needed for native scripts must be
-- supplied as an extra argument.
calculateMinTxFee :: forall era. ()
=> ShelleyBasedEra era
-> Ledger.PParams (ShelleyLedgerEra era)
-> UTxO era
-> TxBody era
-> Word -- ^ The number of Shelley key witnesses
-> L.Coin
calculateMinTxFee sbe pp utxo txbody keywitcount =
shelleyBasedEraConstraints sbe $
case makeSignedTransaction' (shelleyBasedToCardanoEra sbe) [] txbody of
ShelleyTx _ tx ->
L.calcMinFeeTx (toLedgerUTxO sbe utxo) pp tx (fromIntegral keywitcount)
-- | 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
data ResolvablePointers where
ResolvablePointers ::
( Ledger.Era (ShelleyLedgerEra era)
, Show (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era))
, Show (L.PlutusPurpose L.AsItem (ShelleyLedgerEra era))
, Show (Alonzo.PlutusScript (ShelleyLedgerEra era))
)
=> ShelleyBasedEra era
-> !(Map
(L.PlutusPurpose L.AsIx (ShelleyLedgerEra era))
( L.PlutusPurpose L.AsItem (ShelleyLedgerEra era)
, Maybe (PlutusScriptBytes, Plutus.Language)
, Ledger.ScriptHash Ledger.StandardCrypto
)
)
-> ResolvablePointers
deriving instance Show ResolvablePointers
-- | 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.
--
-- TODO: We should replace ScriptWitnessIndex with ledger's
-- PlutusPurpose AsIx ledgerera. This would necessitate the
-- parameterization of ScriptExecutionError.
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
ScriptWitnessIndex -- 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 Plutus.Language
deriving Show
instance Error ScriptExecutionError where
prettyError = \case
ScriptErrorMissingTxIn txin ->
"The supplied UTxO is missing the txin " <> pretty (renderTxIn txin)
ScriptErrorTxInWithoutDatum txin ->
mconcat
[ "The Plutus script witness for the txin does not have a script datum "
, "(according to the UTxO). The txin in question is "
, pretty (renderTxIn txin)
]
ScriptErrorWrongDatum dh ->
mconcat
[ "The Plutus script witness has the wrong datum (according to the UTxO). "
, "The expected datum value has hash " <> pshow dh
]
ScriptErrorEvaluationFailed evalErr logs ->
mconcat
[ "The Plutus script evaluation failed: " <> pretty evalErr
, "\nScript debugging logs: " <> mconcat (map (\t -> pretty $ t `Text.append` "\n") logs)
]
ScriptErrorExecutionUnitsOverflow ->
mconcat
[ "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."
]
ScriptErrorNotPlutusWitnessedTxIn scriptWitness scriptHash ->
mconcat
[ pretty (renderScriptWitnessIndex scriptWitness)
, " is not a Plutus script witnessed tx input and cannot be spent using a "
, "Plutus script witness.The script hash is " <> pshow scriptHash <> "."
]
ScriptErrorRedeemerPointsToUnknownScriptHash scriptWitness ->
mconcat
[ pretty (renderScriptWitnessIndex scriptWitness)
, " points to a script hash that is not known."
]
ScriptErrorMissingScript rdmrPtr resolveable ->
mconcat
[ "The redeemer pointer: " <> pshow rdmrPtr <> " points to a Plutus "
, "script that does not exist.\n"
, "The pointers that can be resolved are: " <> pshow resolveable
]
ScriptErrorMissingCostModel language ->
"No cost model was found for language " <> pshow language
data TransactionValidityError era where
-- | 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 -> TransactionValidityError era
TransactionValidityTranslationError
:: Plutus.EraPlutusContext (ShelleyLedgerEra era)
=> Plutus.ContextError (ShelleyLedgerEra era)
-> TransactionValidityError era
TransactionValidityCostModelError
:: (Map AnyPlutusScriptVersion CostModel) -> String -> TransactionValidityError era
deriving instance Show (TransactionValidityError era)
instance Error (TransactionValidityError era) where
prettyError = \case
TransactionValidityIntervalError pastTimeHorizon ->
mconcat
[ "The transaction validity interval is too far in the future. "
, "For this network it must not be more than "
, pretty (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.
TransactionValidityTranslationError errmsg ->
"Error translating the transaction context: " <> pshow errmsg
TransactionValidityCostModelError cModels err ->
mconcat
[ "An error occurred while converting from the cardano-api cost"
, " models to the cardano-ledger cost models. Error: " <> pretty err
, " Cost models: " <> pshow 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. ()
=> CardanoEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> UTxO era
-> TxBody era
-> Either (TransactionValidityError era)
(Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evaluateTransactionExecutionUnits era systemstart epochInfo pp utxo txbody =
case makeSignedTransaction' era [] txbody of
ShelleyTx sbe tx' -> evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo pp utxo tx'
evaluateTransactionExecutionUnitsShelley :: forall era. ()
=> ShelleyBasedEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> UTxO era
-> L.Tx (ShelleyLedgerEra era)
-> Either (TransactionValidityError era)
(Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
evaluateTransactionExecutionUnitsShelley sbe systemstart epochInfo (LedgerProtocolParameters pp) utxo tx =
caseShelleyToMaryOrAlonzoEraOnwards
(const (Right Map.empty))
(\w -> case alonzoEraOnwardsConstraints w $ L.evalTxExUnits pp tx (toLedgerUTxO sbe utxo) ledgerEpochInfo systemstart of
Left err -> Left $ alonzoEraOnwardsConstraints w
$ TransactionValidityTranslationError err
Right exmap -> Right (fromLedgerScriptExUnitsMap w exmap)
)
sbe
where
LedgerEpochInfo ledgerEpochInfo = epochInfo
fromLedgerScriptExUnitsMap
:: Alonzo.AlonzoEraScript (ShelleyLedgerEra era)
=> AlonzoEraOnwards era
-> Map (L.PlutusPurpose L.AsIx (ShelleyLedgerEra era))
(Either (L.TransactionScriptFailure (ShelleyLedgerEra era)) Alonzo.ExUnits)
-> Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
fromLedgerScriptExUnitsMap aOnwards exmap =
Map.fromList
[ (toScriptIndex aOnwards rdmrptr,
bimap (fromAlonzoScriptExecutionError aOnwards) fromAlonzoExUnits exunitsOrFailure)
| (rdmrptr, exunitsOrFailure) <- Map.toList exmap ]
fromAlonzoScriptExecutionError
:: Alonzo.AlonzoEraScript (ShelleyLedgerEra era)
=> AlonzoEraOnwards era
-> L.TransactionScriptFailure (ShelleyLedgerEra era)
-> ScriptExecutionError
fromAlonzoScriptExecutionError aOnwards =
shelleyBasedEraConstraints sbe $ \case
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.ValidationFailure _ evalErr logs _ ->
-- TODO: Include additional information from ValidationFailure
ScriptErrorEvaluationFailed evalErr logs
L.IncompatibleBudget _ -> ScriptErrorExecutionUnitsOverflow
L.RedeemerPointsToUnknownScriptHash rdmrPtr ->
ScriptErrorRedeemerPointsToUnknownScriptHash $ toScriptIndex aOnwards 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 indexOfScriptWitnessedItem resolveable ->
let scriptWitnessedItemIndex = toScriptIndex aOnwards indexOfScriptWitnessedItem
in ScriptErrorMissingScript scriptWitnessedItemIndex
$ ResolvablePointers sbe $ Map.map extractScriptBytesAndLanguage resolveable
L.NoCostModelInLedgerState l -> ScriptErrorMissingCostModel l
extractScriptBytesAndLanguage
:: Alonzo.AlonzoEraScript (ShelleyLedgerEra era)
=> ( L.PlutusPurpose L.AsItem (ShelleyLedgerEra era)
, Maybe (Alonzo.PlutusScript (ShelleyLedgerEra era))
, L.ScriptHash Ledger.StandardCrypto
)
-> ( L.PlutusPurpose L.AsItem (ShelleyLedgerEra era)
, Maybe (PlutusScriptBytes, Plutus.Language)
, Ledger.ScriptHash Ledger.StandardCrypto
)
extractScriptBytesAndLanguage (purpose, mbScript, scriptHash) =
(purpose, fmap extractPlutusScriptAndLanguage mbScript, scriptHash)
extractPlutusScriptAndLanguage
:: Alonzo.AlonzoEraScript (ShelleyLedgerEra era)
=> Alonzo.PlutusScript (ShelleyLedgerEra era)
-> (PlutusScriptBytes, Plutus.Language)
extractPlutusScriptAndLanguage p =
let bin = Plutus.unPlutusBinary $ Alonzo.plutusScriptBinary p
l = Alonzo.plutusScriptLanguage p
in (bin, l)
-- ----------------------------------------------------------------------------
-- 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. ()
=> ShelleyBasedEra era
-> Ledger.PParams (ShelleyLedgerEra era)
-> Set PoolId
-> Map StakeCredential L.Coin
-> Map (Ledger.Credential Ledger.DRepRole Ledger.StandardCrypto) L.Coin
-> UTxO era
-> TxBody era
-> TxOutValue era
evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo (ShelleyTxBody _ txbody _ _ _ _) =
shelleyBasedEraConstraints sbe
$ TxOutValueShelleyBased sbe
$ L.evalBalanceTxBody
pp
lookupDelegDeposit
lookupDRepDeposit
isRegPool
(toLedgerUTxO sbe utxo)
txbody
where
isRegPool :: Ledger.KeyHash Ledger.StakePool Ledger.StandardCrypto -> Bool
isRegPool kh = StakePoolKeyHash kh `Set.member` poolids
lookupDelegDeposit ::
Ledger.Credential 'Ledger.Staking L.StandardCrypto -> Maybe L.Coin
lookupDelegDeposit stakeCred =
Map.lookup (fromShelleyStakeCredential stakeCred) stakeDelegDeposits
lookupDRepDeposit ::
Ledger.Credential 'Ledger.DRepRole L.StandardCrypto -> Maybe L.Coin
lookupDRepDeposit drepCred =
Map.lookup drepCred drepDelegDeposits
-- ----------------------------------------------------------------------------
-- Automated transaction building
--
-- | The possible errors that can arise from 'makeTransactionBodyAutoBalance'.
--
data TxBodyErrorAutoBalance era =
-- | 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
-- | 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 L.Coin
-- | 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
L.Coin
-- ^ Tx balance
L.Coin
-- | '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 era)
-- | The minimum spendable UTxO threshold has not been met.
| TxBodyErrorMinUTxONotMet
-- ^ Offending TxOut
TxOutInAnyEra
-- ^ Minimum UTxO
L.Coin
| TxBodyErrorNonAdaAssetsUnbalanced Value
| TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap
ScriptWitnessIndex
(Map ScriptWitnessIndex ExecutionUnits)
deriving Show
instance Error (TxBodyErrorAutoBalance era) where
prettyError = \case
TxBodyError err ->
prettyError err
TxBodyScriptExecutionError failures ->
mconcat
[ "The following scripts have execution failures:\n"
, vsep
[ mconcat
[ "the script for " <> pretty (renderScriptWitnessIndex index)
, " failed with: " <> "\n" <> prettyError failure
]
| (index, failure) <- failures
]
]
TxBodyScriptBadScriptValidity ->
"One or more of the scripts were expected to fail validation, but none did."
TxBodyErrorAdaBalanceNegative lovelace ->
mconcat
[ "The transaction does not balance in its use of ada. The net balance "
, "of the transaction is negative: " <> pretty lovelace <> ". "
, "The usual solution is to provide more inputs, or inputs with more ada."
]
TxBodyErrorAdaBalanceTooSmall changeOutput minUTxO balance ->
mconcat
[ "The transaction does balance in its use of ada, however the net "
, "balance does not meet the minimum UTxO threshold. \n"
, "Balance: " <> pretty balance <> "\n"
, "Offending output (change output): " <> pretty (prettyRenderTxOut changeOutput) <> "\n"
, "Minimum UTxO threshold: " <> pretty minUTxO <> "\n"
, "The usual solution is to provide more inputs, or inputs with more ada to "
, "meet the minimum UTxO threshold"
]
TxBodyErrorByronEraNotSupported ->
"The Byron era is not yet supported by makeTransactionBodyAutoBalance"
TxBodyErrorMissingParamMinUTxO ->
"The minUTxOValue protocol parameter is required but missing"
TxBodyErrorValidityInterval err ->
prettyError err
TxBodyErrorMinUTxONotMet txout minUTxO ->
mconcat
[ "Minimum UTxO threshold not met for tx output: " <> pretty (prettyRenderTxOut txout) <> "\n"
, "Minimum required UTxO: " <> pretty minUTxO
]
TxBodyErrorNonAdaAssetsUnbalanced val ->
"Non-Ada assets are unbalanced: " <> pretty (renderValue val)
TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap sIndex eUnitsMap ->
mconcat
[ "ScriptWitnessIndex (redeemer pointer): " <> pshow sIndex <> " is missing from the execution "
, "units (redeemer pointer) map: " <> pshow eUnitsMap
]
handleExUnitsErrors ::
ScriptValidity -- ^ Mark script as expected to pass or fail validation
-> Map ScriptWitnessIndex ScriptExecutionError
-> Map ScriptWitnessIndex ExecutionUnits
-> Either (TxBodyErrorAutoBalance era) (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)
L.Coin -- ^ 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. ()
=> ShelleyBasedEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> Set PoolId -- ^ The set of registered stake pools, that are being
-- unregistered in this transaction.
-> Map StakeCredential L.Coin
-- ^ Map of all deposits for stake credentials that are being
-- unregistered in this transaction
-> Map (Ledger.Credential Ledger.DRepRole Ledger.StandardCrypto) L.Coin
-- ^ Map of all deposits for drep credentials that are being
-- unregistered in this transaction
-> UTxO era -- ^ Just the transaction inputs, not the entire 'UTxO'.
-> TxBodyContent BuildTx era
-> AddressInEra era -- ^ Change address
-> Maybe Word -- ^ Override key witnesses
-> Either (TxBodyErrorAutoBalance era) (BalancedTxBody era)
makeTransactionBodyAutoBalance sbe systemstart history lpp@(LedgerProtocolParameters pp) poolids stakeDelegDeposits
drepDelegDeposits utxo txbodycontent changeaddr mnkeys =
shelleyBasedEraConstraints sbe $ 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 sbe txbodycontent
{ txOuts = txOuts txbodycontent ++
[TxOut changeaddr (lovelaceToTxOutValue sbe 0) TxOutDatumNone ReferenceScriptNone]
--TODO: think about the size of the change output
-- 1,2,4 or 8 bytes?
}
exUnitsMap <- first TxBodyErrorValidityInterval $
evaluateTransactionExecutionUnits
era
systemstart history
lpp
utxo
txbody0
exUnitsMap' <-
case Map.mapEither id exUnitsMap of
(failures, exUnitsMap') ->
handleExUnitsErrors
(txScriptValidityToScriptValidity (txScriptValidity txbodycontent))
failures
exUnitsMap'
txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent
-- Make a txbody that we will use for calculating the fees. For the purpose
-- of fees we just need to make a txbody of the right size in bytes. We do
-- not need the right values for the fee or change output. We use
-- "big enough" values for the change output and set so that the CBOR
-- encoding size of the tx will be big enough to cover the size of the final
-- output and fee. Yes this means this current code will only work for
-- final fee of less than around 4000 ada (2^32-1 lovelace) and change output
-- of less than around 18 trillion ada (2^64-1 lovelace).
-- However, since at this point we know how much non-Ada change to give
-- we can use the true values for that.
let maxLovelaceChange = L.Coin (2^(64 :: Integer)) - 1
let maxLovelaceFee = L.Coin (2^(32 :: Integer) - 1)
let outgoing = mconcat [v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- txOuts txbodycontent]
let incoming = mconcat [v | (TxOut _ (TxOutValueShelleyBased _ v) _ _) <- Map.elems $ unUTxO utxo]
let minted = case txMintValue txbodycontent1 of
TxMintNone -> mempty
TxMintValue w v _ -> toLedgerValue w v
let change = mconcat [incoming, minted, negateLedgerValue sbe outgoing]
let changeWithMaxLovelace = change & A.adaAssetL sbe .~ maxLovelaceChange
let changeTxOut = forShelleyBasedEraInEon sbe
(lovelaceToTxOutValue sbe maxLovelaceChange)
(\w -> maryEraOnwardsConstraints w $ TxOutValueShelleyBased sbe changeWithMaxLovelace)
let (dummyCollRet, dummyTotColl) = maybeDummyTotalCollAndCollReturnOutput txbodycontent changeaddr
txbody1 <- first TxBodyError $ -- TODO: impossible to fail now
createAndValidateTransactionBody sbe txbodycontent1 {
txFee = TxFeeExplicit sbe maxLovelaceFee,
txOuts = TxOut changeaddr changeTxOut TxOutDatumNone ReferenceScriptNone
: txOuts txbodycontent,
txReturnCollateral = dummyCollRet,
txTotalCollateral = dummyTotColl
}
let nkeys = fromMaybe (estimateTransactionKeyWitnessCount txbodycontent1)
mnkeys
fee = calculateMinTxFee sbe pp utxo txbody1 nkeys
(retColl, reqCol) =
caseShelleyToAlonzoOrBabbageEraOnwards
(const (TxReturnCollateralNone, TxTotalCollateralNone))
(\w ->
calcReturnAndTotalCollateral w
fee pp (txInsCollateral txbodycontent) (txReturnCollateral txbodycontent)
(txTotalCollateral txbodycontent) changeaddr utxo
)
sbe
-- Make a txbody for calculating the balance. For this the size of the tx
-- does not matter, instead it's just the values of the fee and outputs.
-- Here we do not want to start with any change output, since that's what
-- we need to calculate.
txbody2 <- first TxBodyError $ -- TODO: impossible to fail now
createAndValidateTransactionBody sbe txbodycontent1 {
txFee = TxFeeExplicit sbe fee,
txReturnCollateral = retColl,
txTotalCollateral = reqCol
}
let balance = evaluateTransactionBalance sbe pp poolids stakeDelegDeposits drepDelegDeposits utxo txbody2
forM_ (txOuts txbodycontent1) $ \txout -> checkMinUTxOValue txout pp
-- check if the balance is positive or negative
-- in one case we can produce change, in the other the inputs are insufficient
balanceCheck pp balance
--TODO: we could add the extra fee for the CBOR encoding of the change,
-- now that we know the magnitude of the change: i.e. 1-8 bytes extra.
-- The txbody with the final fee and change output. This should work
-- provided that the fee and change are less than 2^32-1, and so will
-- fit within the encoding size we picked above when calculating the fee.
-- Yes this could be an over-estimate by a few bytes if the fee or change
-- would fit within 2^16-1. That's a possible optimisation.
let finalTxBodyContent = txbodycontent1 {
txFee = TxFeeExplicit sbe fee,
txOuts = accountForNoChange
(TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone)
(txOuts txbodycontent),
txReturnCollateral = retColl,
txTotalCollateral = reqCol
}
txbody3 <-
first TxBodyError $ -- TODO: impossible to fail now. We need to implement a function
-- that simply creates a transaction body because we have already
-- validated the transaction body earlier within makeTransactionBodyAutoBalance
createAndValidateTransactionBody sbe finalTxBodyContent
return (BalancedTxBody finalTxBodyContent txbody3 (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) fee)
where
-- Essentially we check for the existence of collateral inputs. If they exist we
-- create a fictitious collateral return output. Why? Because we need to put dummy values
-- to get a fee estimate (i.e we overestimate the fee.)
maybeDummyTotalCollAndCollReturnOutput
:: TxBodyContent BuildTx era -> AddressInEra era -> (TxReturnCollateral CtxTx era, TxTotalCollateral era)
maybeDummyTotalCollAndCollReturnOutput TxBodyContent{txInsCollateral, txReturnCollateral, txTotalCollateral} cAddr =
case txInsCollateral of
TxInsCollateralNone -> (TxReturnCollateralNone, TxTotalCollateralNone)
TxInsCollateral{} ->
forEraInEon era
(TxReturnCollateralNone, TxTotalCollateralNone)
(\w ->
let dummyRetCol =
TxReturnCollateral w
( TxOut cAddr
(lovelaceToTxOutValue sbe $ L.Coin (2^(64 :: Integer)) - 1)
TxOutDatumNone ReferenceScriptNone
)
dummyTotCol = TxTotalCollateral w (L.Coin (2^(32 :: Integer) - 1))
in case (txReturnCollateral, txTotalCollateral) of
(rc@TxReturnCollateral{}, tc@TxTotalCollateral{}) -> (rc, tc)
(rc@TxReturnCollateral{},TxTotalCollateralNone) -> (rc, dummyTotCol)
(TxReturnCollateralNone,tc@TxTotalCollateral{}) -> (dummyRetCol, tc)
(TxReturnCollateralNone, TxTotalCollateralNone) -> (dummyRetCol, dummyTotCol)
)
-- Calculation taken from validateInsufficientCollateral: https://github.com/input-output-hk/cardano-ledger/blob/389b266d6226dedf3d2aec7af640b3ca4984c5ea/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs#L335
-- TODO: Bug Jared to expose a function from the ledger that returns total and return collateral.
calcReturnAndTotalCollateral :: ()
=> Ledger.AlonzoEraPParams (ShelleyLedgerEra era)
=> BabbageEraOnwards era
-> L.Coin -- ^ Fee
-> Ledger.PParams (ShelleyLedgerEra era)
-> TxInsCollateral era -- ^ From the initial TxBodyContent
-> TxReturnCollateral CtxTx era -- ^ From the initial TxBodyContent
-> TxTotalCollateral era -- ^ From the initial TxBodyContent
-> AddressInEra era -- ^ Change address
-> UTxO era
-> (TxReturnCollateral CtxTx era, TxTotalCollateral era)
calcReturnAndTotalCollateral _ _ _ TxInsCollateralNone _ _ _ _= (TxReturnCollateralNone, TxTotalCollateralNone)
calcReturnAndTotalCollateral _ _ _ _ rc@TxReturnCollateral{} tc@TxTotalCollateral{} _ _ = (rc,tc)
calcReturnAndTotalCollateral retColSup fee pp' (TxInsCollateral _ collIns) txReturnCollateral txTotalCollateral cAddr (UTxO utxo') =
do
let colPerc = pp' ^. Ledger.ppCollateralPercentageL
-- We must first figure out how much lovelace we have committed
-- as collateral and we must determine if we have enough lovelace at our
-- collateral tx inputs to cover the tx
let txOuts = catMaybes [ Map.lookup txin utxo' | txin <- collIns]
totalCollateralLovelace = mconcat $ map (\(TxOut _ txOutVal _ _) -> txOutValueToLovelace txOutVal) txOuts
requiredCollateral@(L.Coin reqAmt) = fromIntegral colPerc * fee
totalCollateral = TxTotalCollateral retColSup . L.rationalToCoinViaCeiling
$ reqAmt % 100
-- Why * 100? requiredCollateral is the product of the collateral percentage and the tx fee
-- We choose to multiply 100 rather than divide by 100 to make the calculation
-- easier to manage. At the end of the calculation we then use % 100 to perform our division
-- and round up.
enoughCollateral = totalCollateralLovelace * 100 >= requiredCollateral
L.Coin amt = totalCollateralLovelace * 100 - requiredCollateral
returnCollateral = L.rationalToCoinViaFloor $ amt % 100
case (txReturnCollateral, txTotalCollateral) of
#if MIN_VERSION_base(4,16,0)
#else
-- For ghc-9.2, this pattern match is redundant, but ghc-8.10 will complain if its missing.
(rc@TxReturnCollateral{}, tc@TxTotalCollateral{}) ->
(rc, tc)
#endif
(rc@TxReturnCollateral{}, TxTotalCollateralNone) ->
(rc, TxTotalCollateralNone)
(TxReturnCollateralNone, tc@TxTotalCollateral{}) ->
(TxReturnCollateralNone, tc)
(TxReturnCollateralNone, TxTotalCollateralNone) ->
if enoughCollateral
then
( TxReturnCollateral
retColSup
(TxOut cAddr (lovelaceToTxOutValue sbe returnCollateral) TxOutDatumNone ReferenceScriptNone)
, totalCollateral
)
else (TxReturnCollateralNone, TxTotalCollateralNone)
era :: CardanoEra era
era = shelleyBasedToCardanoEra sbe
-- In the event of spending the exact amount of lovelace in
-- the specified input(s), this function excludes the change
-- output. Note that this does not save any fees because by default
-- the fee calculation includes a change address for simplicity and
-- we make no attempt to recalculate the tx fee without a change address.
accountForNoChange :: TxOut CtxTx era -> [TxOut CtxTx era] -> [TxOut CtxTx era]
accountForNoChange change@(TxOut _ balance _ _) rest =
case txOutValueToLovelace balance of
L.Coin 0 -> rest
-- We append change at the end so a client can predict the indexes
-- of the outputs
_ -> rest ++ [change]
balanceCheck :: Ledger.PParams (ShelleyLedgerEra era) -> TxOutValue era -> Either (TxBodyErrorAutoBalance era) ()
balanceCheck bpparams balance
| txOutValueToLovelace balance == 0 && onlyAda (txOutValueToValue balance) = return ()
| txOutValueToLovelace balance < 0 =
Left . TxBodyErrorAdaBalanceNegative $ txOutValueToLovelace balance
| otherwise =
case checkMinUTxOValue (TxOut changeaddr balance TxOutDatumNone ReferenceScriptNone) bpparams of
Left (TxBodyErrorMinUTxONotMet txOutAny minUTxO) ->
Left $ TxBodyErrorAdaBalanceTooSmall txOutAny minUTxO (txOutValueToLovelace balance)
Left err -> Left err
Right _ -> Right ()
isNotAda :: AssetId -> Bool
isNotAda AdaAssetId = False
isNotAda _ = True
onlyAda :: Value -> Bool
onlyAda = null . valueToList . filterValue isNotAda
checkMinUTxOValue
:: TxOut CtxTx era
-> Ledger.PParams (ShelleyLedgerEra era)
-> Either (TxBodyErrorAutoBalance era) ()
checkMinUTxOValue txout@(TxOut _ v _ _) bpp = do
let minUTxO = calculateMinimumUTxO sbe txout bpp
if txOutValueToLovelace v >= minUTxO
then Right ()
else Left $ TxBodyErrorMinUTxONotMet (txOutInAnyEra era txout) minUTxO
substituteExecutionUnits :: Map ScriptWitnessIndex ExecutionUnits
-> TxBodyContent BuildTx era
-> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era)
substituteExecutionUnits exUnitsMap =
mapTxScriptWitnesses f
where
f :: ScriptWitnessIndex
-> ScriptWitness witctx era
-> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era)
f _ wit@SimpleScriptWitness{} = Right wit
f idx (PlutusScriptWitness langInEra version script datum redeemer _) =
case Map.lookup idx exUnitsMap of
Nothing ->
Left $ TxBodyErrorScriptWitnessIndexMissingFromExecUnitsMap idx exUnitsMap
Just exunits -> Right $ PlutusScriptWitness langInEra version script
datum redeemer exunits
mapTxScriptWitnesses
:: forall era.
(forall witctx. ScriptWitnessIndex
-> ScriptWitness witctx era
-> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era))
-> TxBodyContent BuildTx era
-> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era)
mapTxScriptWitnesses f txbodycontent@TxBodyContent {
txIns,
txWithdrawals,
txCertificates,
txMintValue
} = do
mappedTxIns <- mapScriptWitnessesTxIns txIns
mappedWithdrawals <- mapScriptWitnessesWithdrawals txWithdrawals
mappedMintedVals <- mapScriptWitnessesMinting txMintValue