Skip to content

Commit 8c04d25

Browse files
UnisayUnisay
committed
WIP
1 parent 64508dd commit 8c04d25

File tree

1 file changed

+188
-5
lines changed

1 file changed

+188
-5
lines changed

‎plutus-benchmark/linear-vesting/src/PlutusBenchmark/LinearVesting.hs

Lines changed: 188 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,13 @@
11
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE LambdaCase #-}
23
{-# LANGUAGE MultiParamTypeClasses #-}
4+
{-# LANGUAGE NamedFieldPuns #-}
35
{-# LANGUAGE NoImplicitPrelude #-}
46
{-# LANGUAGE PatternSynonyms #-}
57
{-# LANGUAGE Strict #-}
68
{-# LANGUAGE TemplateHaskell #-}
79
{-# LANGUAGE ViewPatterns #-}
10+
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
811
{-# OPTIONS_GHC -fno-full-laziness #-}
912
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
1013
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
@@ -17,15 +20,26 @@
1720

1821
module PlutusBenchmark.LinearVesting where
1922

23+
import PlutusLedgerApi.V3
24+
import PlutusTx
2025
import PlutusTx.Prelude
21-
22-
import PlutusLedgerApi.V1.Value (AssetClass)
23-
import PlutusLedgerApi.V3 (Address, Datum (..), ScriptContext, scriptContextScriptInfo)
24-
import PlutusLedgerApi.V3.Contexts (pattern SpendingScript)
25-
import PlutusTx (CompiledCode, compile, makeIsDataIndexed, makeLift)
2626
import Prelude qualified as Haskell
2727

28+
import PlutusLedgerApi.V1.Value (AssetClass, assetClassValueOf)
29+
import PlutusTx.Builtins.HasOpaque (stringToBuiltinByteString, stringToBuiltinString)
2830
import PlutusTx.Builtins.Internal qualified as BI
31+
import PlutusTx.List qualified as List
32+
33+
{-
34+
data PAssetClassData (s :: S) = PAssetClassData (Term s (PDataRecord '["symbol" ':= PCurrencySymbol, "tokenName" ':= PTokenName]))
35+
deriving stock (Generic)
36+
deriving anyclass (PlutusType, PIsData, PDataFields)
37+
38+
ptoScottEncoding :: Term s (PAssetClassData :--> PAssetClass)
39+
ptoScottEncoding = phoistAcyclic $ plam $ \x' -> P.do
40+
x <- pletFields @["symbol", "tokenName"] x'
41+
pcon $ PAssetClass x.symbol x.tokenName
42+
-}
2943

3044
data VestingDatum = VestingDatum
3145
{ beneficiary :: Address
@@ -51,6 +65,175 @@ $( PlutusTx.makeIsDataIndexed
5165
[('PartialUnlock, 0), ('FullUnlock, 1)]
5266
)
5367

68+
countInputsAtScript :: ScriptHash -> [TxInInfo] -> Integer
69+
countInputsAtScript scriptHash inputs = 42
70+
71+
{-
72+
pcountInputsAtScript :: Term s (PScriptHash :--> PBuiltinList PTxInInfo :--> PInteger)
73+
pcountInputsAtScript =
74+
phoistAcyclic $ plam $ \sHash ->
75+
let go :: Term _ (PInteger :--> PBuiltinList PTxInInfo :--> PInteger)
76+
go = pfix #$ plam $ \self n ->
77+
pelimList
78+
( \x xs ->
79+
let cred = pfield @"credential" # (pfield @"address" # (pfield @"resolved" # x))
80+
in pmatch cred $ \case
81+
PScriptCredential ((pfield @"_0" #) -> vh) -> pif (sHash #== vh) (self # (n + 1) # xs) (self # n # xs)
82+
_ -> self # n # xs
83+
)
84+
n
85+
in go # 0
86+
-}
87+
88+
validateVestingPartialUnlock :: VestingDatum -> ScriptContext -> BuiltinUnit
89+
validateVestingPartialUnlock vestingDatum ctx =
90+
let
91+
txInfo = scriptContextTxInfo ctx
92+
SpendingScript ownRef (Just datum) = scriptContextScriptInfo ctx
93+
outputs = txInfoOutputs txInfo
94+
inputs = txInfoInputs txInfo
95+
signatories = txInfoSignatories txInfo
96+
validRange = txInfoValidRange txInfo
97+
Just ownVestingInput = List.find ((== ownRef) . txInInfoOutRef) inputs
98+
resolvedOut = txInInfoResolved ownVestingInput
99+
inputAddress = txOutAddress resolvedOut
100+
inputValue = txOutValue resolvedOut
101+
inputDdatum = txOutDatum resolvedOut
102+
ScriptCredential scriptHash = addressCredential inputAddress
103+
Just ownVestingOutput = List.find ((== inputAddress) . txOutAddress) outputs
104+
outputAddress = txOutAddress ownVestingOutput
105+
outputValue = txOutValue ownVestingOutput
106+
outputDatum = txOutDatum ownVestingOutput
107+
108+
asset = vestingAsset vestingDatum
109+
currentTimeApproximation = getLowerInclusiveTimeRange validRange
110+
oldRemainingQty = assetClassValueOf inputValue asset
111+
newRemainingQty = assetClassValueOf outputValue asset
112+
vestingPeriodLength = vestingPeriodEnd vestingDatum - vestingPeriodStart vestingDatum
113+
vestingTimeRemaining = vestingPeriodEnd vestingDatum - currentTimeApproximation
114+
timeBetweenTwoInstallments = ceiling (vestingPeriodLength `div` totalInstallments vestingDatum)
115+
futureInstallments = ceiling (vestingTimeRemaining `div` timeBetweenTwoInstallments)
116+
in
117+
_
118+
119+
{-
120+
121+
pvalidateVestingPartialUnlock ::
122+
Term
123+
s
124+
( PVestingDatum
125+
:--> PScriptContext
126+
:--> PUnit
127+
)
128+
pvalidateVestingPartialUnlock = phoistAcyclic $ plam $ \datum ctx -> unTermCont $ do
129+
ctxF <- pletFieldsC @'["txInfo", "purpose"] ctx
130+
txInfoF <- pletFieldsC @'["outputs", "inputs", "signatories", "validRange"] ctxF.txInfo
131+
PSpending ((pfield @"_0" #) -> ownRef) <- pmatchC ctxF.purpose
132+
133+
PJust ownVestingInput <- pmatchC $ pfindOwnInput # txInfoF.inputs # ownRef
134+
ownVestingInputF <- pletFieldsC @'["address", "value", "datum"] (pfield @"resolved" # ownVestingInput)
135+
PScriptCredential ((pfield @"_0" #) -> ownValHash) <- pmatchC (pfield @"credential" # ownVestingInputF.address)
136+
137+
ownVestingOutput <- pletC $ pheadSingleton #$ pfindOutputsToAddress # txInfoF.outputs # ownVestingInputF.address
138+
ownVestingOutputF <- pletFieldsC @'["address", "value", "datum"] ownVestingOutput
139+
140+
datumF <-
141+
pletFieldsC
142+
@'[ "beneficiary"
143+
, "vestingAsset"
144+
, "totalVestingQty"
145+
, "vestingPeriodStart"
146+
, "vestingPeriodEnd"
147+
, "firstUnlockPossibleAfter"
148+
, "totalInstallments"
149+
]
150+
datum
151+
152+
vestingAsset <- pletC $ ptoScottEncoding # datumF.vestingAsset
153+
currentTimeApproximation <- pletC $ pfromData $ pto $ pgetLowerInclusiveTimeRange # txInfoF.validRange
154+
155+
oldRemainingQty <- pletC $ passetClassValueOf # vestingAsset # ownVestingInputF.value
156+
newRemainingQty <- pletC $ passetClassValueOf # vestingAsset # ownVestingOutputF.value
157+
vestingPeriodLength <- pletC $ (pfromData datumF.vestingPeriodEnd) - (pfromData datumF.vestingPeriodStart)
158+
vestingTimeRemaining <- pletC $ (pfromData datumF.vestingPeriodEnd) - (currentTimeApproximation)
159+
timeBetweenTwoInstallments <- pletC $ pdivCeil # vestingPeriodLength # datumF.totalInstallments
160+
futureInstallments <- pletC $ pdivCeil # (vestingTimeRemaining) # (timeBetweenTwoInstallments)
161+
162+
let expectedRemainingQty = pdivCeil # (futureInstallments * datumF.totalVestingQty) #$ datumF.totalInstallments
163+
164+
PPubKeyCredential ((pfield @"_0" #) -> beneficiaryHash) <- pmatchC (pfield @"credential" # datumF.beneficiary)
165+
166+
pguardC "Missing beneficiary signature" (ptxSignedBy # txInfoF.signatories # beneficiaryHash)
167+
pguardC "Unlock not permitted until firstUnlockPossibleAfter time" (datumF.firstUnlockPossibleAfter #< currentTimeApproximation)
168+
pguardC "Zero remaining assets not allowed" (0 #< newRemainingQty)
169+
pguardC "Remaining asset exceed old asset" (newRemainingQty #< oldRemainingQty)
170+
pguardC "Mismatched remaining asset" (expectedRemainingQty #== newRemainingQty)
171+
pguardC "Datum Modification Prohibited" (ownVestingInputF.datum #== ownVestingOutputF.datum)
172+
pguardC "Double satisfaction" (pcountInputsAtScript # ownValHash # txInfoF.inputs #== 1)
173+
pure $ pconstant ()
174+
175+
pvalidateVestingFullUnlock :: Term s (PVestingDatum :--> PScriptContext :--> PUnit)
176+
pvalidateVestingFullUnlock = phoistAcyclic $ plam $ \datum context -> unTermCont $ do
177+
datumF <- tcont $ pletFields @'["beneficiary", "vestingPeriodEnd"] datum
178+
txInfoF <- tcont $ pletFields @'["signatories", "validRange"] $ pfield @"txInfo" # context
179+
currentTimeApproximation <- pletC $ pfromData $ pto $ pgetLowerInclusiveTimeRange # txInfoF.validRange
180+
PPubKeyCredential ((pfield @"_0" #) -> beneficiaryHash) <- pmatchC (pfield @"credential" # datumF.beneficiary)
181+
182+
pguardC "Missing beneficiary signature" (ptxSignedBy # txInfoF.signatories # beneficiaryHash)
183+
pguardC "Unlock not permitted until vestingPeriodEnd time" (datumF.vestingPeriodEnd #< currentTimeApproximation)
184+
pure $ pconstant ()
185+
186+
pvalidateVestingScript ::
187+
Term
188+
s
189+
( PVestingDatum
190+
:--> PVestingRedeemer
191+
:--> PScriptContext
192+
:--> PUnit
193+
)
194+
pvalidateVestingScript =
195+
phoistAcyclic $
196+
plam $
197+
\datum redeemer context -> unTermCont $ do
198+
pure $
199+
pmatch redeemer $ \case
200+
PPartialUnlock _ -> pvalidateVestingPartialUnlock # datum # context
201+
PFullUnlock _ -> pvalidateVestingFullUnlock # datum # context
202+
203+
pvalidateVestingScriptValidator :: Term s PValidator
204+
pvalidateVestingScriptValidator = phoistAcyclic $
205+
plam $ \dat red ctx -> unTermCont $ do
206+
let datum = ptryFrom dat fst
207+
let redeemer = punsafeCoerce red
208+
return $
209+
popaque $
210+
pvalidateVestingScript # datum # redeemer # ctx
211+
212+
pgetLowerInclusiveTimeRange :: forall (s :: S). Term s ( PPOSIXTimeRange :--> (PAsData PPOSIXTime))
213+
pgetLowerInclusiveTimeRange = phoistAcyclic $
214+
plam $ \timeRange -> unTermCont $ do
215+
PInterval ((pfield @"from" #) -> from) <- pmatchC timeRange
216+
PLowerBound lb <- pmatchC from
217+
218+
let tryBound = phoistAcyclic $
219+
plam $ \endpoint a ->
220+
pmatch (pfield @"_0" # a) $ \case
221+
PFinite ((pfield @"_0" #) -> posixTime) ->
222+
pif
223+
(pfield @"_1" # a)
224+
(posixTime)
225+
(pdata $ (pfromData posixTime) + endpoint)
226+
_ -> ptraceError "Time range not Finite"
227+
inclusiveLb <- pletC $ tryBound # (1) # lb
228+
pure $ inclusiveLb
229+
-}
230+
231+
getLowerInclusiveTimeRange :: POSIXTimeRange -> POSIXTime
232+
getLowerInclusiveTimeRange = \case
233+
Interval (LowerBound (Finite posixTime) inclusive) _upperBound ->
234+
if inclusive then posixTime else posixTime + 1
235+
_ -> traceError (stringToBuiltinString "Time range not Finite")
236+
54237
validatorCode :: CompiledCode (BuiltinData -> BuiltinUnit)
55238
validatorCode = $$(compile [||untypedValidator||])
56239

0 commit comments

Comments
 (0)