-
Notifications
You must be signed in to change notification settings - Fork 721
/
FundSet.hs
270 lines (225 loc) · 9.81 KB
/
FundSet.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
{-# OPTIONS_GHC -Wwarn #-}
{-# Language DataKinds #-}
{-# Language FlexibleInstances #-}
{-# Language GADTs #-}
{-# Language GeneralizedNewtypeDeriving #-}
{-# Language MultiParamTypeClasses #-}
{-# Language RankNTypes #-}
{-# Language TypeApplications #-}
{-# Language ScopedTypeVariables #-}
module Cardano.Benchmarking.FundSet
where
import Prelude
import Data.IxSet.Typed as IxSet
import Data.Proxy
import Control.Applicative ((<|>))
import Cardano.Api as Api
-- Outputs that are available for spending.
-- When building a new TX they provide the TxIn parts.
data FundInEra era = FundInEra {
_fundTxIn :: !TxIn
, _fundWitness :: Witness WitCtxTxIn era
, _fundVal :: !(TxOutValue era)
, _fundSigningKey :: !(Maybe (SigningKey PaymentKey))
, _fundVariant :: !Variant
, _fundValidity :: !Validity
} deriving (Show)
data Variant
= PlainOldFund
-- maybe better use the script itself instead of the filePath
| PlutusScriptFund
-- A collateralFund is just a regular (PlainOldFund) on the chain,
-- but tagged in the wallet so that it is not selected for spending.
| CollateralFund
deriving (Show, Eq, Ord)
data Validity
= Confirmed
| InFlight !Target !SeqNumber
deriving (Show, Eq, Ord)
newtype Target = Target String
deriving (Show, Eq, Ord)
newtype SeqNumber = SeqNumber Int
deriving (Show, Eq, Ord, Enum)
newtype Fund = Fund {unFund :: InAnyCardanoEra FundInEra}
getFundVariant :: Fund -> Variant
getFundVariant (Fund (InAnyCardanoEra _ a)) = _fundVariant a
getFundTxIn :: Fund -> TxIn
getFundTxIn (Fund (InAnyCardanoEra _ a)) = _fundTxIn a
getFundKey :: Fund -> Maybe (SigningKey PaymentKey)
getFundKey (Fund (InAnyCardanoEra _ a)) = _fundSigningKey a
getFundValidity :: Fund -> Validity
getFundValidity (Fund (InAnyCardanoEra _ a)) = _fundValidity a
getFundLovelace :: Fund -> Lovelace
getFundLovelace (Fund (InAnyCardanoEra _ a)) = case _fundVal a of
TxOutAdaOnly _era l -> l
TxOutValue _era v -> selectLovelace v
-- This effectively rules out era-transitions for transactions !
-- This is not what we want !!
getFundWitness :: forall era. IsShelleyBasedEra era => Fund -> Witness WitCtxTxIn era
getFundWitness fund = case (cardanoEra @ era, fund) of
(ByronEra , Fund (InAnyCardanoEra ByronEra a)) -> _fundWitness a
(ShelleyEra , Fund (InAnyCardanoEra ShelleyEra a)) -> _fundWitness a
(AllegraEra , Fund (InAnyCardanoEra AllegraEra a)) -> _fundWitness a
(MaryEra , Fund (InAnyCardanoEra MaryEra a)) -> _fundWitness a
(AlonzoEra , Fund (InAnyCardanoEra AlonzoEra a)) -> _fundWitness a
(BabbageEra , Fund (InAnyCardanoEra BabbageEra a)) -> _fundWitness a
-- This effectively rules out era-transitions for transactions !
-- This is not what we want !!
-- It should be possible to cast KeyWitnesses from one era to an other !
(_ , _) -> error "getFundWitness: era mismatch"
data IsConfirmed = IsConfirmed | IsNotConfirmed
deriving (Show, Eq, Ord)
isConfirmed :: Fund -> IsConfirmed
isConfirmed f = case getFundValidity f of
Confirmed -> IsConfirmed
InFlight _ _ -> IsNotConfirmed
instance Show Fund where
show (Fund (InAnyCardanoEra _ f)) = show f
-- TxIn/fundTxOut is the primary key.
-- There must be no two entries for the same TxIn !.
instance Eq Fund where
(==) a b = getFundTxIn a == getFundTxIn b
instance Ord Fund where
compare a b = compare (getFundTxIn a) (getFundTxIn b)
type FundIndices = '[ TxIn, IsConfirmed, Target, SeqNumber, Lovelace, Variant ]
type FundSet = IxSet FundIndices Fund
instance Indexable FundIndices Fund where
indices = ixList
(ixFun $ \f -> [ getFundTxIn f ])
(ixFun $ \f -> [ isConfirmed f ])
(ixFun $ \f -> case getFundValidity f of
Confirmed -> []
InFlight t _ -> [t]
)
(ixFun $ \f -> case getFundValidity f of
Confirmed -> [SeqNumber (-1) ] -- Confirmed Txs get SeqNumber -1
InFlight _ n -> [ n ]
)
(ixFun $ \f -> [ getFundLovelace f ])
(ixFun $ \f -> [ getFundVariant f ])
emptyFunds :: FundSet
emptyFunds = IxSet.empty
insertFund :: FundSet -> Fund -> FundSet
insertFund s f = updateIx (getFundTxIn f) f s
deleteFund :: FundSet -> Fund -> FundSet
deleteFund s f = deleteIx (getFundTxIn f) s
liftAnyEra :: ( forall era. IsCardanoEra era => f1 era -> f2 era ) -> InAnyCardanoEra f1 -> InAnyCardanoEra f2
liftAnyEra f x = case x of
InAnyCardanoEra ByronEra a -> InAnyCardanoEra ByronEra $ f a
InAnyCardanoEra ShelleyEra a -> InAnyCardanoEra ShelleyEra $ f a
InAnyCardanoEra AllegraEra a -> InAnyCardanoEra AllegraEra $ f a
InAnyCardanoEra MaryEra a -> InAnyCardanoEra MaryEra $ f a
InAnyCardanoEra AlonzoEra a -> InAnyCardanoEra AlonzoEra $ f a
InAnyCardanoEra BabbageEra a -> InAnyCardanoEra BabbageEra $ f a
type FundSelector = FundSet -> Either String [Fund]
type FundSource m = m (Either String [Fund])
type FundToStore m = [Fund] -> m ()
-- Select Funds to cover a minimum value.
-- TODO:
-- This fails unless there is a single fund with the required value
-- Extend this to really return a list of funds.
selectMinValue :: Lovelace -> FundSet -> Either String [Fund]
selectMinValue minValue fs = case coins of
[] -> Left $ "findSufficientCoin: no single coin with min value >= " ++ show minValue
(c:_) -> Right [c]
where coins = toAscList ( Proxy :: Proxy Lovelace) (fs @=PlainOldFund @= IsConfirmed @>= minValue)
selectCollateral :: FundSet -> Either String [Fund]
selectCollateral fs = case coins of
[] -> Left "no matching none-Plutus fund found"
(c:_) -> Right [c]
where
coins = toAscList ( Proxy :: Proxy Lovelace) (fs @=CollateralFund @= IsConfirmed )
data AllowRecycle
= UseConfirmedOnly
| ReuseSameTarget
-- ReuseAny can cause none-deterministic runtime errors !
-- The problematic case is the reuse of an UTxO/Tx that is not yet confirmed
-- and still waits in the mempool of an other target-node.
| ReuseAny
| ConfirmedBeforeReuse -- useful for testing
deriving (Eq, Ord, Enum, Show)
-- There are many possible heuristics to implement the selectInputs function.
-- TODO: Check that the complexity of selectInputs is good enough.
selectInputs ::
AllowRecycle
-> Int
-> Lovelace
-> Variant
-> Target
-> FundSet
-> Either String [Fund]
selectInputs allowRecycle count minTotalValue variant targetNode fs
= case allowRecycle of
UseConfirmedOnly -> selectConfirmed
ReuseSameTarget -> reuseSameTarget <|> selectConfirmed
ReuseAny -> reuseSameTarget <|> selectConfirmed <|> reuseAnyCoin
ConfirmedBeforeReuse -> selectConfirmed <|> reuseSameTarget
where
selectConfirmed = selectConfirmedSmallValue <|> selectConfirmedBigValue
isSufficientCoins coins = length coins == count && sum (map getFundLovelace coins) >= minTotalValue
checkCoins :: String -> [Fund] -> Either String [Fund]
checkCoins err coins
= if isSufficientCoins coins then Right coins else Left err
-- Share intermediate results for variantIxSet confirmedIxSet and targetIxSet
-- TODO: it unclear if this helps on the complexity or it it is even harmful.
variantIxSet = fs @= variant
confirmedIxSet = variantIxSet @= IsConfirmed
targetIxSet = variantIxSet @= targetNode
confirmedBigValueList = toDescList (Proxy :: Proxy Lovelace) confirmedIxSet
sameTargetList = toAscList (Proxy :: Proxy SeqNumber) targetIxSet
selectConfirmedSmallValue
= checkCoins
"selectConfirmedSmall: not enough coins available"
(take count $ toAscList (Proxy :: Proxy Lovelace) confirmedIxSet)
selectConfirmedBigValue
= checkCoins
"selectConfirmedSmall: not enough coins available"
(take count confirmedBigValueList)
-- reuseSameTargetStrict is problematic: It fails if the coins in the queues are too small. But it will never consume the small coins.
-- therefore: (reuseSameTargetStrict <|> reuseSameTargetWithBackup)
reuseSameTargetStrict
= checkCoins
"reuseSameTargetStrict: not enough coins available"
(take count sameTargetList)
-- reuseSameTargetWithBackup can collect some dust.
-- reuseSameTargetWithBackup works fine if there is at least one sufficient confirmed UTxO available.
reuseSameTargetWithBackup = checkCoins "reuseSameTargetWithBackup: not enough coins available" (backupCoin ++ targetCoins)
where
-- targetCoins and backupCoins must be disjoint.
-- This is case because IsConfirmed \= InFlight target.
backupCoin = take 1 $ toAscList (Proxy :: Proxy Lovelace) (confirmedIxSet @> minTotalValue)
targetCoins = take (count - 1) sameTargetList
reuseSameTarget = reuseSameTargetStrict <|> reuseSameTargetWithBackup
-- reuseAnyCoin is the last resort !
reuseAnyCoin
= checkCoins
"reuseAnyTarget: not enough coins available"
(take count $ confirmedBigValueList ++ inFlightCoins)
where
-- inFlightCoins and confirmedCoins are disjoint
inFlightCoins = toAscList (Proxy :: Proxy SeqNumber) (variantIxSet @=IsNotConfirmed)
selectToBuffer ::
Int
-> Lovelace
-> Maybe Variant
-> FundSet
-> Either String [Fund]
selectToBuffer count minValue variant fs
= if length coins < count
then Left $ concat
[ "selectToBuffer: not enough coins found: count: ", show count
, " minValue: ", show minValue
, " variant: ", show variant
]
else Right coins
where
coins = case variant of
Just v -> take count $ toAscList ( Proxy :: Proxy Lovelace) (fs @=v @= IsConfirmed @>= minValue)
Nothing -> take count $ toAscList ( Proxy :: Proxy Lovelace) (fs @= IsConfirmed @>= minValue)
-- Todo: check sufficient funds and minimumValuePerUtxo
inputsToOutputsWithFee :: Lovelace -> Int -> [Lovelace] -> [Lovelace]
inputsToOutputsWithFee fee count inputs = map (quantityToLovelace . Quantity) outputs
where
(Quantity totalAvailable) = lovelaceToQuantity $ sum inputs - fee
(out, rest) = divMod totalAvailable (fromIntegral count)
outputs = (out + rest) : replicate (count-1) out