Skip to content

Commit ee15d36

Browse files
UnisayUnisay
authored
Benchmark: Linear Vesting (#7166)
* Linear Vesting: benchmark executable * refactor(linear-vesting): split validator and test code.
1 parent a17e1a3 commit ee15d36

File tree

4 files changed

+298
-0
lines changed

4 files changed

+298
-0
lines changed

‎plutus-benchmark/linear-vesting/exe/Main.hs

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
module Main (main) where
2+
3+
import Data.Text qualified as Text
4+
import LinearVesting.Test (validatorCodeFullyApplied)
5+
import PlutusTx.Test (displayEvalResult, evaluateCompiledCode)
6+
7+
main :: IO ()
8+
main = do
9+
putStrLn ""
10+
putStrLn $
11+
Text.unpack $
12+
displayEvalResult $
13+
evaluateCompiledCode validatorCodeFullyApplied

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

Lines changed: 80 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,80 @@
1+
{-# LANGUAGE BlockArguments #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE MultiParamTypeClasses #-}
4+
{-# LANGUAGE NamedFieldPuns #-}
5+
{-# LANGUAGE NoImplicitPrelude #-}
6+
{-# LANGUAGE OverloadedStrings #-}
7+
{-# LANGUAGE Strict #-}
8+
9+
module LinearVesting.Test where
10+
11+
import PlutusTx
12+
import PlutusTx.Prelude
13+
14+
import LinearVesting.Validator (VestingDatum (..), VestingRedeemer (..), validatorCode)
15+
import PlutusLedgerApi.Data.V3
16+
import PlutusLedgerApi.V1.Data.Value (assetClass)
17+
import PlutusTx.Data.AssocMap qualified as Map
18+
import PlutusTx.Data.List qualified as List
19+
20+
validatorCodeFullyApplied :: CompiledCode BuiltinUnit
21+
validatorCodeFullyApplied =
22+
validatorCode `unsafeApplyCode` liftCodeDef (toBuiltinData testScriptContext)
23+
24+
testScriptContext :: ScriptContext
25+
testScriptContext =
26+
ScriptContext
27+
{ scriptContextTxInfo = txInfo
28+
, scriptContextRedeemer
29+
, scriptContextScriptInfo
30+
}
31+
where
32+
txInfo =
33+
TxInfo
34+
{ txInfoInputs = mempty
35+
, txInfoReferenceInputs = mempty
36+
, txInfoOutputs = mempty
37+
, txInfoTxCerts = mempty
38+
, txInfoRedeemers = Map.empty
39+
, txInfoVotes = Map.empty
40+
, txInfoProposalProcedures = mempty
41+
, txInfoCurrentTreasuryAmount = Nothing
42+
, txInfoTreasuryDonation = Nothing
43+
, txInfoFee = 0
44+
, txInfoMint = emptyMintValue
45+
, txInfoWdrl = Map.empty
46+
, txInfoValidRange =
47+
Interval
48+
(LowerBound (Finite 110) True)
49+
(UpperBound (Finite 1100) True)
50+
, txInfoSignatories = List.singleton testBeneficiaryPKH
51+
, txInfoData = Map.empty
52+
, txInfoId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145"
53+
}
54+
55+
scriptContextRedeemer :: Redeemer
56+
scriptContextRedeemer = Redeemer (toBuiltinData FullUnlock)
57+
58+
scriptContextScriptInfo :: ScriptInfo
59+
scriptContextScriptInfo =
60+
SpendingScript (TxOutRef txOutRefId txOutRefIdx) (Just datum)
61+
where
62+
txOutRefId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145"
63+
txOutRefIdx = 0
64+
datum :: Datum
65+
datum = Datum (toBuiltinData testVestingDatum)
66+
67+
testVestingDatum :: VestingDatum
68+
testVestingDatum =
69+
VestingDatum
70+
{ beneficiary = Address (PubKeyCredential testBeneficiaryPKH) Nothing
71+
, vestingAsset = assetClass (CurrencySymbol "$") (TokenName "test-asset")
72+
, totalVestingQty = 1000
73+
, vestingPeriodStart = 0
74+
, vestingPeriodEnd = 100
75+
, firstUnlockPossibleAfter = 10
76+
, totalInstallments = 10
77+
}
78+
79+
testBeneficiaryPKH :: PubKeyHash
80+
testBeneficiaryPKH = PubKeyHash ""

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

Lines changed: 180 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,180 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE BlockArguments #-}
3+
{-# LANGUAGE DataKinds #-}
4+
{-# LANGUAGE LambdaCase #-}
5+
{-# LANGUAGE MultiParamTypeClasses #-}
6+
{-# LANGUAGE MultiWayIf #-}
7+
{-# LANGUAGE NamedFieldPuns #-}
8+
{-# LANGUAGE NoImplicitPrelude #-}
9+
{-# LANGUAGE OverloadedStrings #-}
10+
{-# LANGUAGE PatternSynonyms #-}
11+
{-# LANGUAGE Strict #-}
12+
{-# LANGUAGE TemplateHaskell #-}
13+
{-# LANGUAGE ViewPatterns #-}
14+
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
15+
{-# OPTIONS_GHC -fno-full-laziness #-}
16+
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
17+
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
18+
{-# OPTIONS_GHC -fno-spec-constr #-}
19+
{-# OPTIONS_GHC -fno-specialise #-}
20+
{-# OPTIONS_GHC -fno-strictness #-}
21+
{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-}
22+
{-# OPTIONS_GHC -fno-unbox-strict-fields #-}
23+
{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
24+
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:conservative-optimisation #-}
25+
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-remove-trace #-}
26+
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:preserve-logging #-}
27+
28+
module LinearVesting.Validator where
29+
30+
import PlutusTx
31+
import PlutusTx.Prelude
32+
import Prelude qualified as Haskell
33+
34+
import PlutusLedgerApi.Data.V3
35+
import PlutusLedgerApi.V1.Data.Value (AssetClass, assetClassValueOf)
36+
import PlutusLedgerApi.V3.Data.Contexts (txSignedBy)
37+
import PlutusTx.Data.List (List)
38+
import PlutusTx.Data.List qualified as List
39+
40+
data VestingDatum = VestingDatum
41+
{ beneficiary :: Address
42+
, vestingAsset :: AssetClass
43+
, totalVestingQty :: Integer
44+
, vestingPeriodStart :: Integer
45+
, vestingPeriodEnd :: Integer
46+
, firstUnlockPossibleAfter :: Integer
47+
, totalInstallments :: Integer
48+
}
49+
deriving stock (Haskell.Show)
50+
51+
$(makeLift ''VestingDatum)
52+
$(makeIsDataIndexed ''VestingDatum [('VestingDatum, 0)])
53+
54+
data VestingRedeemer = PartialUnlock | FullUnlock
55+
56+
$(PlutusTx.makeLift ''VestingRedeemer)
57+
$( PlutusTx.makeIsDataIndexed
58+
''VestingRedeemer
59+
[('PartialUnlock, 0), ('FullUnlock, 1)]
60+
)
61+
62+
countInputsAtScript :: ScriptHash -> List TxInInfo -> Integer
63+
countInputsAtScript scriptHash = go 0
64+
where
65+
go :: Integer -> List TxInInfo -> Integer
66+
go n = List.caseList' n \txIn txIns ->
67+
case addressCredential (txOutAddress (txInInfoResolved txIn)) of
68+
ScriptCredential vh | vh == scriptHash -> go (n + 1) txIns
69+
_ -> go n txIns
70+
71+
validateVestingPartialUnlock :: ScriptContext -> Bool
72+
validateVestingPartialUnlock ctx =
73+
let
74+
txInfo :: TxInfo = scriptContextTxInfo ctx
75+
SpendingScript ownRef (Just (Datum datum)) = scriptContextScriptInfo ctx
76+
vestingDatum :: VestingDatum = unsafeFromBuiltinData datum
77+
inputs = txInfoInputs txInfo
78+
79+
Just ownVestingInput = List.find ((== ownRef) . txInInfoOutRef) inputs
80+
resolvedOut = txInInfoResolved ownVestingInput
81+
inputAddress = txOutAddress resolvedOut
82+
83+
ScriptCredential scriptHash = addressCredential inputAddress
84+
Just ownVestingOutput =
85+
List.find ((== inputAddress) . txOutAddress) (txInfoOutputs txInfo)
86+
outputDatum = txOutDatum ownVestingOutput
87+
88+
divCeil :: Integer -> Integer -> Integer
89+
divCeil x y = 1 + (x - 1) `divide` y
90+
91+
asset :: AssetClass =
92+
vestingAsset vestingDatum
93+
oldRemainingQty :: Integer =
94+
assetClassValueOf (txOutValue resolvedOut) asset
95+
newRemainingQty :: Integer =
96+
assetClassValueOf (txOutValue ownVestingOutput) asset
97+
vestingPeriodLength :: Integer =
98+
vestingPeriodEnd vestingDatum - vestingPeriodStart vestingDatum
99+
currentTimeApproximation :: Integer =
100+
getPOSIXTime (getLowerInclusiveTimeRange (txInfoValidRange txInfo))
101+
vestingTimeRemaining :: Integer =
102+
vestingPeriodEnd vestingDatum - currentTimeApproximation
103+
timeBetweenTwoInstallments :: Integer =
104+
vestingPeriodLength `divCeil` totalInstallments vestingDatum
105+
futureInstallments :: Integer =
106+
vestingTimeRemaining `divCeil` timeBetweenTwoInstallments
107+
expectedRemainingQty :: Integer =
108+
(futureInstallments * totalVestingQty vestingDatum)
109+
`divCeil` totalInstallments vestingDatum
110+
PubKeyCredential beneficiaryHash =
111+
addressCredential (beneficiary vestingDatum)
112+
in
113+
if
114+
| not (txSignedBy txInfo beneficiaryHash) ->
115+
traceError "Missing beneficiary signature"
116+
| firstUnlockPossibleAfter vestingDatum >= currentTimeApproximation ->
117+
traceError "Unlock not permitted until firstUnlockPossibleAfter time"
118+
| newRemainingQty <= 0 ->
119+
traceError "Zero remaining assets not allowed"
120+
| newRemainingQty >= oldRemainingQty ->
121+
traceError "Remaining asset is not decreasing"
122+
| expectedRemainingQty /= newRemainingQty ->
123+
traceError "Mismatched remaining asset"
124+
| txOutDatum resolvedOut /= outputDatum ->
125+
traceError "Datum Modification Prohibited"
126+
| countInputsAtScript scriptHash inputs /= 1 ->
127+
traceError "Double satisfaction"
128+
| otherwise ->
129+
True
130+
131+
validateVestingFullUnlock :: ScriptContext -> Bool
132+
validateVestingFullUnlock ctx =
133+
let
134+
txInfo :: TxInfo = scriptContextTxInfo ctx
135+
currentTimeApproximation :: Integer =
136+
getPOSIXTime (getLowerInclusiveTimeRange (txInfoValidRange txInfo))
137+
SpendingScript _ownRef (Just (Datum datum)) = scriptContextScriptInfo ctx
138+
vestingDatum :: VestingDatum = unsafeFromBuiltinData datum
139+
PubKeyCredential beneficiaryKey = addressCredential (beneficiary vestingDatum)
140+
in
141+
if
142+
| not (txSignedBy txInfo beneficiaryKey) ->
143+
traceError "Missing beneficiary signature"
144+
| vestingPeriodEnd vestingDatum >= currentTimeApproximation ->
145+
traceError "Unlock not permitted until vestingPeriodEnd time"
146+
| otherwise ->
147+
True
148+
149+
getLowerInclusiveTimeRange :: POSIXTimeRange -> POSIXTime
150+
getLowerInclusiveTimeRange = \case
151+
Interval (LowerBound (Finite posixTime) inclusive) _upperBound ->
152+
if inclusive then posixTime else posixTime + 1
153+
_ -> traceError "Time range not Finite"
154+
155+
{-# INLINEABLE typedValidator #-}
156+
typedValidator :: ScriptContext -> Bool
157+
typedValidator context =
158+
trace "Validation completed"
159+
$ case redeemer of
160+
FullUnlock ->
161+
validateVestingFullUnlock $ trace "Full unlock requested" context
162+
PartialUnlock ->
163+
validateVestingPartialUnlock $ trace "Partial unlock requested" context
164+
where
165+
{-# INLINEABLE redeemer #-}
166+
redeemer :: VestingRedeemer
167+
redeemer =
168+
case fromBuiltinData (getRedeemer (scriptContextRedeemer context)) of
169+
Nothing -> traceError "Failed to parse Redeemer"
170+
Just r -> trace "Parsed Redeemer" r
171+
172+
{-# INLINEABLE untypedValidator #-}
173+
untypedValidator :: BuiltinData -> BuiltinUnit
174+
untypedValidator scriptContextData =
175+
case trace "Parsing ScriptContext..." (fromBuiltinData scriptContextData) of
176+
Nothing -> traceError "Failed to parse ScriptContext"
177+
Just ctx -> check $ typedValidator $ trace "Parsed ScriptContext" ctx
178+
179+
validatorCode :: CompiledCode (BuiltinData -> BuiltinUnit)
180+
validatorCode = $$(compile [||untypedValidator||])

‎plutus-benchmark/plutus-benchmark.cabal

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -670,3 +670,28 @@ benchmark bitwise-bench
670670
, criterion
671671
, plutus-benchmark-common
672672
, plutus-tx ^>=1.48
673+
674+
------------------ linear vesting -------------------
675+
676+
library linear-vesting-internal
677+
import: lang, ghc-version-support, os-support
678+
hs-source-dirs: linear-vesting/src
679+
exposed-modules:
680+
LinearVesting.Test
681+
LinearVesting.Validator
682+
683+
build-depends:
684+
, base >=4.9 && <5
685+
, plutus-ledger-api
686+
, plutus-tx
687+
, plutus-tx-plugin
688+
689+
executable linear-vesting
690+
import: lang, ghc-version-support, os-support
691+
main-is: Main.hs
692+
hs-source-dirs: linear-vesting/exe
693+
build-depends:
694+
, base >=4.9 && <5
695+
, linear-vesting-internal
696+
, plutus-tx:plutus-tx-testlib
697+
, text

0 commit comments

Comments
 (0)