-
Notifications
You must be signed in to change notification settings - Fork 0
/
Api.hs
196 lines (164 loc) · 9.32 KB
/
Api.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
-- {-# LANGUAGE DeriveGeneric #-}
-- {-# LANGUAGE DeriveAnyClass #-}
module Vesting.Api
( vestingAddress
, availableVestings
, availableVestingsFromBenefactor
, placeVesting
, claimVestingBeneficiary
, cancelVestingBenefactor
) where
import qualified Data.Map.Strict as Map
import GeniusYield.TxBuilder
import GeniusYield.Types
import Vesting.Script (vestingValidatorGY,vestingAddress)
import Vesting.OnChain.Vesting (VestingDatum(..),VestingRedeemer(..),getAdaAmountFromValue)
-- imports suggested by ChatGPT
import PlutusLedgerApi.V2 (fromBuiltinData)
import PlutusLedgerApi.V1.Value (assetClass)
import GHC.Generics()
import Cardano.Api()
import PlutusTx()
import Control.Monad (filterM)
{-
-- Corresponding off-chain types using GY types
data GYVestingDatum = GYVestingDatum
{ gyBeneficiary :: GYPubKeyHash
, gyBenefactor :: GYPubKeyHash
, gyDeadline :: GYTime
, gyAmount :: Integer
} deriving (Show, Generic, ToJSON, FromJSON, ToData,FromData)
data GYVestingRedeemer = GYClaim | GYCancel
deriving (Show, Generic, ToJSON, FromJSON, ToData, FromData)
-}
{-
-- Function to convert on-chain VestingDatum to GYVestingDatum
vestingDatumToGY :: VestingDatum -> GYVestingDatum
vestingDatumToGY (VestingDatum benf benr dl amnt) =
GYVestingDatum (pubKeyHashToGY benf) (pubKeyHashToGY benr) (timeToPlutus dl) amnt
-- Function to handle VestingRedeemer in GY types
vestingRedeemerToGY :: VestingRedeemer -> GYVestingRedeemer
vestingRedeemerToGY Claim = GYClaim
vestingRedeemerToGY Cancel = GYCancel
-}
{-
placeVesting :: GYTxQueryMonad m => GYPubKeyHash -> GYTime -> GYValue -> m (GYTxSkeleton 'PlutusV2)
placeVesting beneficiary deadline value = do
addr <- vestingAddress
return $ mustHaveOutput $ GYTxOut
{ gyTxOutAddress = addr
, gyTxOutValue = value
, gyTxOutDatum = Just (datumFromPlutusData $ timeToPlutus deadline, GYTxOutUseInlineDatum)
, gyTxOutRefS = Nothing
}
-}
-- set up initial state to deploy Vesting contract
placeVesting :: GYTxQueryMonad m => GYPubKeyHash -> GYPubKeyHash -> GYTime -> GYValue -> m (GYTxSkeleton 'PlutusV2)
placeVesting benefactor beneficiary deadline valueAmount =
do addr <- vestingAddress
return $ mustHaveOutput $ GYTxOut
{ gyTxOutAddress = addr
, gyTxOutValue = valueAmount
, gyTxOutDatum = Just (datumFromPlutusData $ VestingDatum (pubKeyHashToPlutus benefactor) (pubKeyHashToPlutus beneficiary) (timeToPlutus deadline) amt, GYTxOutUseInlineDatum)
, gyTxOutRefS = Nothing
}
where
amt = getAdaAmountFromValue $ valueToPlutus valueAmount
gyAdaAssetClass :: GYAssetClass
gyAdaAssetClass = case assetClassFromPlutus (assetClass adaSymbol adaToken) of
Right gyac -> gyac
Left err -> error ("ill-formed asset class: " ++ show err)
availableVestings :: GYTxQueryMonad m => GYPubKeyHash -> m [(GYTxOutRef, GYTime)]
availableVestings beneficiaryPkh = do
slot <- slotOfCurrentBlock
now <- slotToBeginTime slot
addr <- vestingAddress
utxos <- utxosAtAddress addr Nothing
utxos' <- utxosDatums utxos
orefDatums <- filterM (filterCondition now) (Map.toList utxos')
return [ (oref, timeFromPlutus $ deadline datum) | (oref, (_,_,datum)) <- orefDatums ]
where
filterCondition gyTime (oref, (_,_,datum)) = do
pkh <- pubKeyHashFromPlutus' $ beneficiary datum
return $ gyTime > timeFromPlutus (deadline datum)
&& pkh == beneficiaryPkh
availableVestingsFromBenefactor :: GYTxQueryMonad m => GYPubKeyHash -> m [(GYTxOutRef, GYTime)]
availableVestingsFromBenefactor benefactorPkh = do
slot <- slotOfCurrentBlock
now <- slotToBeginTime slot
addr <- vestingAddress
utxos <- utxosAtAddress addr Nothing
utxos' <- utxosDatums utxos
orefDatums <- filterM (filterCondition now) (Map.toList utxos')
return [ (oref, timeFromPlutus $ deadline datum) | (oref, (_,_,datum)) <- orefDatums ]
where
filterCondition gyTime (oref, (_,_,datum)) = do
pkh <- pubKeyHashFromPlutus' $ benefactor datum
return $ gyTime <= timeFromPlutus (deadline datum)
&& pkh == benefactorPkh
-- implement business logic of Claim method
claimVestingBeneficiary :: (GYTxQueryMonad m) => GYNetworkId -> GYTxOutRef -> m (GYTxSkeleton 'PlutusV2)
claimVestingBeneficiary nId oref = do
slot <- slotOfCurrentBlock
mUtxomDatum <- utxoAtTxOutRefWithDatum oref
case mUtxomDatum of
Just (_utxo ,Just datum) ->
case decodeDatum datum of
Just (VestingDatum _ beneficiary _ amt) ->
let rBeneficiaryPkh = pubKeyHashFromPlutus beneficiary
in case rBeneficiaryPkh of
Right beneficiaryPkh ->
let addressBeneficiary = addressFromPubKeyHash nId beneficiaryPkh
in return $ isInvalidBefore slot <> -- sets up the validity interval
mustBeSignedBy beneficiaryPkh <> -- adds a required signatory
mustHaveInput GYTxIn -- adds input
{ gyTxInTxOutRef = oref
, gyTxInWitness = GYTxInWitnessScript
(GYInScript vestingValidatorGY)
(datumFromPlutusData datum)
(redeemerFromPlutusData Claim)
} <>
mustHaveOutput GYTxOut -- adds payment output
{ gyTxOutAddress = addressBeneficiary
, gyTxOutValue = valueFromLovelace $ toInteger amt
, gyTxOutDatum = Nothing
, gyTxOutRefS = Nothing
}
Left err ->
error "unparseable beneficiary"
Nothing -> error "ill-formed utxo"
Nothing -> error "ill-formed utxo"
-- Decodes Datum to VestingDatum
decodeDatum :: GYDatum -> Maybe VestingDatum
decodeDatum d = fromBuiltinData $ datumToPlutus' d
-- implement business logic of Cancel method
cancelVestingBenefactor :: (GYTxQueryMonad m) => GYNetworkId -> GYTxOutRef -> m (GYTxSkeleton 'PlutusV2)
cancelVestingBenefactor nId oref = do
mUtxomDatum <- utxoAtTxOutRefWithDatum oref
case mUtxomDatum of
Just (_utxo ,Just datum) ->
case decodeDatum datum of
Just (VestingDatum benefactor _ deadline amt) -> do
deadlineSlot <- enclosingSlotFromTime' (timeFromPlutus deadline)
let rBenefactorPkh = pubKeyHashFromPlutus benefactor
case rBenefactorPkh of
Right benefactorPkh ->
let addressBenefactor = addressFromPubKeyHash nId benefactorPkh
in return $ isInvalidAfter deadlineSlot <> -- sets up the validity interval
mustBeSignedBy benefactorPkh <> -- adds a required signatory
mustHaveInput GYTxIn -- adds input
{ gyTxInTxOutRef = oref
, gyTxInWitness = GYTxInWitnessScript
(GYInScript vestingValidatorGY)
(datumFromPlutusData datum)
(redeemerFromPlutusData Cancel)
} <>
mustHaveOutput GYTxOut -- adds payment output
{ gyTxOutAddress = addressBenefactor
, gyTxOutValue = valueFromLovelace $ toInteger amt
, gyTxOutDatum = Nothing
, gyTxOutRefS = Nothing
}
Left err -> error "unparseable benefactor"
Nothing -> error "ill-formed utxo"
Nothing -> error "ill-formed utxo"