diff --git a/cardano-dex-contracts-offchain/Contracts/vesting.uplc b/cardano-dex-contracts-offchain/Contracts/vesting.uplc new file mode 100644 index 00000000..7c0805e3 Binary files /dev/null and b/cardano-dex-contracts-offchain/Contracts/vesting.uplc differ diff --git a/cardano-dex-contracts-offchain/Contracts/vestingWithPeriod.uplc b/cardano-dex-contracts-offchain/Contracts/vestingWithPeriod.uplc new file mode 100644 index 00000000..65673907 Binary files /dev/null and b/cardano-dex-contracts-offchain/Contracts/vestingWithPeriod.uplc differ diff --git a/cardano-dex-contracts-offchain/ErgoDex/Contracts/Pool.hs b/cardano-dex-contracts-offchain/ErgoDex/Contracts/Pool.hs index 198394c1..fe73f579 100644 --- a/cardano-dex-contracts-offchain/ErgoDex/Contracts/Pool.hs +++ b/cardano-dex-contracts-offchain/ErgoDex/Contracts/Pool.hs @@ -38,7 +38,7 @@ import qualified Prelude as Haskell import ErgoDex.Contracts.Types import qualified GHC.Generics as Haskell -import Plutus.V1.Ledger.Value (AssetClass, assetClassValueOf, flattenValue) +import Plutus.V1.Ledger.Value (AssetClass, assetClassValueOf, flattenValue, CurrencySymbol) import Plutus.V1.Ledger.Api (PubKeyHash) import qualified PlutusTx import PlutusTx.Builtins diff --git a/cardano-dex-contracts-offchain/ErgoDex/Contracts/Proxy/Vesting.hs b/cardano-dex-contracts-offchain/ErgoDex/Contracts/Proxy/Vesting.hs new file mode 100644 index 00000000..0874bba5 --- /dev/null +++ b/cardano-dex-contracts-offchain/ErgoDex/Contracts/Proxy/Vesting.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:profile-all #-} + +module ErgoDex.Contracts.Proxy.Vesting where + +import qualified Prelude as Haskell + +import qualified GHC.Generics as GHC +import Plutus.V1.Ledger.Api (PubKeyHash, POSIXTime) +import Plutus.V1.Ledger.Value +import qualified PlutusTx +import PlutusTx.Prelude + +data VestingRedeemer = VestingRedeemer + { vestingInIx :: Integer + , rewardOutIx :: Integer + } + deriving stock (Haskell.Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed ''VestingRedeemer [('VestingRedeemer, 0)] +PlutusTx.makeLift ''VestingRedeemer + +data VestingConfig = VestingConfig + { deadline :: POSIXTime + , pkh :: PubKeyHash + , vestingAC :: AssetClass + } + deriving stock (Haskell.Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed ''VestingConfig [('VestingConfig, 0)] +PlutusTx.makeLift ''VestingConfig \ No newline at end of file diff --git a/cardano-dex-contracts-offchain/ErgoDex/Contracts/Proxy/VestingWithPeriod.hs b/cardano-dex-contracts-offchain/ErgoDex/Contracts/Proxy/VestingWithPeriod.hs new file mode 100644 index 00000000..1c2a7a68 --- /dev/null +++ b/cardano-dex-contracts-offchain/ErgoDex/Contracts/Proxy/VestingWithPeriod.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:profile-all #-} + +module ErgoDex.Contracts.Proxy.VestingWithPeriod where + +import qualified Prelude as Haskell + +import qualified GHC.Generics as GHC +import Plutus.V1.Ledger.Api (PubKeyHash, POSIXTime) +import Plutus.V1.Ledger.Value +import qualified PlutusTx +import PlutusTx.Prelude + +data VestingWithPeriodRedeemer = VestingWithPeriodRedeemer + { vestingInIx :: Integer + , vestingPeriodIdx :: Integer + } + deriving stock (Haskell.Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed ''VestingWithPeriodRedeemer [('VestingWithPeriodRedeemer, 0)] +PlutusTx.makeLift ''VestingWithPeriodRedeemer + +data VestingWithPeriodConfig = VestingWithPeriodConfig + { vestingStart :: POSIXTime + , vestingPeriodDuration :: POSIXTime + , totalVested :: Integer + , periodVested :: Integer + , pkhs :: [PubKeyHash] + , vestingAC :: AssetClass + } + deriving stock (Haskell.Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed ''VestingWithPeriodConfig [('VestingWithPeriodConfig, 0)] +PlutusTx.makeLift ''VestingWithPeriodConfig \ No newline at end of file diff --git a/cardano-dex-contracts-offchain/ErgoDex/Contracts/Typed.hs b/cardano-dex-contracts-offchain/ErgoDex/Contracts/Typed.hs index 8bd657de..adffb5f3 100644 --- a/cardano-dex-contracts-offchain/ErgoDex/Contracts/Typed.hs +++ b/cardano-dex-contracts-offchain/ErgoDex/Contracts/Typed.hs @@ -7,10 +7,10 @@ module ErgoDex.Contracts.Typed where import qualified Prelude as Haskell -import Data.Aeson (FromJSON, ToJSON) import ErgoDex.Contracts.Class import qualified ErgoDex.Contracts.Pool as P import ErgoDex.Contracts.Types +import Plutus.V1.Ledger.Value (CurrencySymbol(..)) import GHC.Generics (Generic) import PlutusTx.Prelude @@ -20,6 +20,8 @@ data PoolConfig = PoolConfig , poolY :: Coin Y , poolLq :: Coin Liquidity , poolFeeNum :: Integer + , stakeAdminPolicy :: [CurrencySymbol] + , lqBound :: Integer } deriving (Haskell.Show, Haskell.Eq, Generic) @@ -31,6 +33,8 @@ instance UnliftErased PoolConfig P.PoolConfig where , poolY = unCoin poolY , poolLq = unCoin poolLq , poolFeeNum = poolFeeNum + , stakeAdminPolicy = stakeAdminPolicy + , lqBound = lqBound } unlift P.PoolConfig{..} = @@ -40,4 +44,6 @@ instance UnliftErased PoolConfig P.PoolConfig where , poolY = Coin poolY , poolLq = Coin poolLq , poolFeeNum = poolFeeNum + , stakeAdminPolicy = stakeAdminPolicy + , lqBound = lqBound } diff --git a/cardano-dex-contracts-offchain/ErgoDex/Contracts/Types.hs b/cardano-dex-contracts-offchain/ErgoDex/Contracts/Types.hs index 53bf06cc..244c673a 100644 --- a/cardano-dex-contracts-offchain/ErgoDex/Contracts/Types.hs +++ b/cardano-dex-contracts-offchain/ErgoDex/Contracts/Types.hs @@ -24,14 +24,7 @@ import Data.Aeson (FromJSON, ToJSON) import GHC.Generics (Generic) import ErgoDex.Plutus (adaAssetClass) -import qualified Data.Text as Text -import qualified Data.Aeson as JSON -import qualified Data.Aeson.Types as JSON -import Plutus.V1.Ledger.Value (AssetClass (..), Value (..), assetClassValue, assetClassValueOf, TokenName(..), CurrencySymbol(..)) -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString as BSS -import qualified Data.Text.Encoding as TE -import Control.Monad ((>=>)) +import Plutus.V1.Ledger.Value (AssetClass (..), Value (..), assetClassValue, assetClassValueOf) import qualified PlutusTx import PlutusTx.Prelude import Text.Printf (PrintfArg) diff --git a/cardano-dex-contracts-offchain/ErgoDex/PValidators.hs b/cardano-dex-contracts-offchain/ErgoDex/PValidators.hs index 05581a6a..d3b20fbd 100644 --- a/cardano-dex-contracts-offchain/ErgoDex/PValidators.hs +++ b/cardano-dex-contracts-offchain/ErgoDex/PValidators.hs @@ -3,6 +3,8 @@ module ErgoDex.PValidators ( swapValidator, depositValidator, redeemValidator, + vestingValidator, + vestingWithPeriodValidator, simpleStakingValidator, lockPkhStakingValidator ) where @@ -51,6 +53,18 @@ lockPkhStakingValidatorDataFileName = "stakinWithPkh.uplc" lockPkhStakingValidator :: (MonadIO m) => m PV2.Validator lockPkhStakingValidator = readValidatorFromFile lockPkhStakingValidatorDataFileName +vestingValidatorDataFileName :: String +vestingValidatorDataFileName = "vesting.uplc" + +vestingValidator :: (MonadIO m) => m PV2.Validator +vestingValidator = readValidatorFromFile vestingValidatorDataFileName + +vestingWithPeriodValidatorDataFileName :: String +vestingWithPeriodValidatorDataFileName = "vestingWithPeriod.uplc" + +vestingWithPeriodValidator :: (MonadIO m) => m PV2.Validator +vestingWithPeriodValidator = readValidatorFromFile vestingWithPeriodValidatorDataFileName + readValidatorFromFile :: (MonadIO m) => String -> m PV2.Validator readValidatorFromFile dataFieldName = do path <- liftIO $ getDataFileName dataFieldName diff --git a/cardano-dex-contracts-offchain/cardano-dex-contracts-offchain.cabal b/cardano-dex-contracts-offchain/cardano-dex-contracts-offchain.cabal index 97f32ae7..5cad1e59 100644 --- a/cardano-dex-contracts-offchain/cardano-dex-contracts-offchain.cabal +++ b/cardano-dex-contracts-offchain/cardano-dex-contracts-offchain.cabal @@ -15,7 +15,7 @@ license: CC0-1.0 license-files: LICENSE author: ErgoLabs maintainer: ilya.arcadich@gmail.com -data-files: deposit.uplc swap.uplc redeem.uplc pool.uplc simpleStaking.uplc +data-files: deposit.uplc swap.uplc redeem.uplc pool.uplc vesting.uplc vestingWithPeriod.uplc simpleStaking.uplc data-dir: Contracts -- A copyright notice. @@ -106,6 +106,8 @@ library ErgoDex.Contracts.Proxy.Deposit ErgoDex.Contracts.Proxy.Order ErgoDex.Contracts.Proxy.Redeem + ErgoDex.Contracts.Proxy.Vesting + ErgoDex.Contracts.Proxy.VestingWithPeriod ErgoDex.PValidators ErgoDex.Contracts.Proxy.Swap ErgoDex.Contracts.Typed diff --git a/cardano-dex-contracts-offchain/test/Tests/Contracts.hs b/cardano-dex-contracts-offchain/test/Tests/Contracts.hs index 2254fb5b..99eb7d52 100644 --- a/cardano-dex-contracts-offchain/test/Tests/Contracts.hs +++ b/cardano-dex-contracts-offchain/test/Tests/Contracts.hs @@ -15,6 +15,8 @@ checkContractsRecovering = testGroup "ContractsRecovering" , HH.testProperty "pool_contract_recovering" poolRecovering , HH.testProperty "deposit_contract_recovering" depositRecovering , HH.testProperty "redeem_contract_recovering" redeemRecovering + , HH.testProperty "vesting_contract_recovering" redeemRecovering + , HH.testProperty "vesting_with_period_contract_recovering" redeemRecovering ] swapRecovering :: Property @@ -28,3 +30,10 @@ redeemRecovering = withTests 1 . property $ evalIO (void redeemValidator) poolRecovering :: Property poolRecovering = withTests 1 . property $ evalIO (void poolValidator) + +vestingRecovering :: Property +vestingRecovering = withTests 1 . property $ evalIO (void vestingValidator) + +vestingWithPeriodRecovering :: Property +vestingWithPeriodRecovering = withTests 1 . property $ evalIO (void vestingWithPeriodValidator) + diff --git a/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/Vesting.hs b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/Vesting.hs new file mode 100644 index 00000000..e60293c5 --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/Vesting.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.Contracts.Proxy.Vesting ( + VestingConfig (..), + VestingRedeemer (..) +) where + +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V1.Value +import PlutusLedgerApi.V1.Time +import qualified PlutusTx + +data VestingRedeemer = VestingRedeemer + { vestingInIx :: Integer + , rewardOutIx :: Integer + } + deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''VestingRedeemer [('VestingRedeemer, 0)] + +data VestingConfig = VestingConfig + { deadline :: POSIXTime + , pkh :: PubKeyHash + , vestingAC :: AssetClass + } + deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''VestingConfig [('VestingConfig, 0)] + diff --git a/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/VestingWithPeriod.hs b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/VestingWithPeriod.hs new file mode 100644 index 00000000..bfc34154 --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/Contracts/Proxy/VestingWithPeriod.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.Contracts.Proxy.VestingWithPeriod ( + VestingWithPeriodConfig (..), + VestingWithPeriodRedeemer (..) +) where + +import PlutusLedgerApi.V1.Crypto (PubKeyHash) +import PlutusLedgerApi.V1.Value +import PlutusLedgerApi.V1.Time +import qualified PlutusTx + +data VestingWithPeriodRedeemer = VestingWithPeriodRedeemer + { vestingInIx :: Integer + , vestingPeriodIdx :: Integer + } + deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''VestingWithPeriodRedeemer [('VestingWithPeriodRedeemer, 0)] + +data VestingWithPeriodConfig = VestingWithPeriodConfig + { vestingStart :: POSIXTime + , vestingPeriodDuration :: POSIXTime + , totalVested :: Integer + , periodVested :: Integer + , pkhs :: [PubKeyHash] + , vestingAC :: AssetClass + } + deriving stock (Show) + +PlutusTx.makeIsDataIndexed ''VestingWithPeriodConfig [('VestingWithPeriodConfig, 0)] + diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PApi.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PApi.hs index 67ed8b77..21ed3468 100644 --- a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PApi.hs +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PApi.hs @@ -1,7 +1,9 @@ module ErgoDex.PContracts.PApi ( containsSignature, + containsSignature', ownCurrencySymbol, getRewardValue', + getRewardValueByPKH', tletUnwrap, pmin, getInputValue, @@ -53,6 +55,9 @@ pmin = phoistAcyclic $ plam $ \a b -> pif (a #<= b) a b containsSignature :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> PPubKeyHash :--> PBool) containsSignature = phoistAcyclic $ plam $ \signatories userPubKeyHash -> pelem # pdata userPubKeyHash # signatories +containsSignature' :: Term s (PBuiltinList (PAsData PPubKeyHash) :--> (PAsData PPubKeyHash) :--> PBool) +containsSignature' = phoistAcyclic $ plam $ \signatories userPubKeyHash -> pelem # userPubKeyHash # signatories + -- Guarantees reward proposition correctness getRewardValue' :: Term s (PTxOut :--> PPubKeyHash :--> PMaybeData PPubKeyHash :--> V1.PValue 'V1.Sorted 'V1.Positive) getRewardValue' = phoistAcyclic $ @@ -69,6 +74,19 @@ getRewardValue' = phoistAcyclic $ sPkh <- tlet $ getStakeHash # addr pure $ pif (sPkh #== stakePkhM) outValue (ptraceError "Invalid reward proposition") +-- Guarantees reward proposition correctness +getRewardValueByPKH' :: Term s (PTxOut :--> PPubKeyHash :--> V1.PValue 'V1.Sorted 'V1.Positive) +getRewardValueByPKH' = phoistAcyclic $ + plam $ \out pubkeyHash -> unTermCont $ do + let addr = pfield @"address" # out + cred <- tletField @"credential" addr + tletUnwrap $ pmatch cred $ \case + PPubKeyCredential pcred -> + let pkh = pfield @"_0" # pcred + value = pfield @"value" # out + in pif (pkh #== pubkeyHash) value (ptraceError "Invalid reward proposition") + _ -> ptraceError "Invalid reward proposition" + getStakeHash :: forall (s :: S). Term s (PAddress :--> PMaybeData PPubKeyHash) getStakeHash = phoistAcyclic $ plam $ \address -> unTermCont $ do diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PValidators.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PValidators.hs index 65233b70..49950a5d 100644 --- a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PValidators.hs +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PValidators.hs @@ -14,6 +14,8 @@ import qualified ErgoDex.PContracts.PDeposit as PD import qualified ErgoDex.PContracts.PPool as PP import qualified ErgoDex.PContracts.PRedeem as PR import qualified ErgoDex.PContracts.PSwap as PS +import qualified ErgoDex.PContracts.PVesting as PV +import qualified ErgoDex.PContracts.PVestingWithPeriod as PVWP import Plutarch import Plutarch.Api.V2 (mkValidator, validatorHash) @@ -43,5 +45,11 @@ depositValidator = mkValidator $ wrapValidator PD.depositValidatorT redeemValidator :: Validator redeemValidator = mkValidator $ wrapValidator PR.redeemValidatorT +vestingValidator :: Validator +vestingValidator = mkValidator $ wrapValidator PV.vestingValidatorT + +vestingWithPeriodValidator :: Validator +vestingWithPeriodValidator = mkValidator $ wrapValidator PVWP.vestingWithPeriodValidatorT + validatorAddress :: Validator -> Address validatorAddress = scriptHashAddress . validatorHash diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PVesting.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PVesting.hs new file mode 100644 index 00000000..b5c99dc3 --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PVesting.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.PContracts.PVesting ( + VestingConfig (..), + vestingValidatorT +) where + +import qualified GHC.Generics as GHC + +import Plutarch +import Plutarch.Api.V2 +import Plutarch.Extra.Interval +import Plutarch.Api.V1.Time +import Plutarch.DataRepr +import Plutarch.Lift +import Plutarch.Prelude +import Plutarch.Extra.TermCont +import Plutarch.Api.V1.Interval (PInterval) +import qualified Plutarch.Monadic as P + +import PExtra.API +import PExtra.Monadic (tlet, tletField) + +import ErgoDex.PContracts.PApi + +import qualified ErgoDex.Contracts.Proxy.Vesting as V + +newtype VestingRedeemer (s :: S) + = VestingRedeemer + ( Term + s + ( PDataRecord + '[ "vestingInIx" ':= PInteger + , "rewardOutIx" ':= PInteger + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType) + +instance DerivePlutusType VestingRedeemer where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl VestingRedeemer where type PLifted VestingRedeemer = V.VestingRedeemer +deriving via (DerivePConstantViaData V.VestingRedeemer VestingRedeemer) instance (PConstantDecl V.VestingRedeemer) + +newtype VestingConfig (s :: S) + = VestingConfig + ( Term + s + ( PDataRecord + '[ "deadline" ':= PPOSIXTime + , "pkh" ':= PPubKeyHash + , "vestingAC" ':= PAssetClass + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType) + +instance DerivePlutusType VestingConfig where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl VestingConfig where type PLifted VestingConfig = V.VestingConfig +deriving via (DerivePConstantViaData V.VestingConfig VestingConfig) instance (PConstantDecl V.VestingConfig) + +vestingValidatorT :: ClosedTerm (VestingConfig :--> VestingRedeemer :--> PScriptContext :--> PBool) +vestingValidatorT = plam $ \conf' redeemer' ctx' -> unTermCont $ do + ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' + conf <- pletFieldsC @'["deadline", "pkh", "vestingAC"] conf' + let + deadline = pfromData $ getField @"deadline" conf + pkh = pfromData $ getField @"pkh" conf + vestingAC = pfromData $ getField @"vestingAC" conf + + txInfo <- pletFieldsC @'["inputs", "outputs", "validRange", "signatories"] $ getField @"txInfo" ctx + redeemer <- pletFieldsC @'["vestingInIx", "rewardOutIx"] redeemer' + let + vestingInIx = getField @"vestingInIx" redeemer + rewardOutIx = getField @"rewardOutIx" redeemer + + validRange <- tletUnwrap $ getField @"validRange" txInfo + inputs <- tletUnwrap $ getField @"inputs" txInfo + outputs <- tletUnwrap $ getField @"outputs" txInfo + + selfIn' <- tlet $ pelemAt # vestingInIx # inputs + selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' + selfValue <- + let self = getField @"resolved" selfIn + in tletField @"value" self + + PSpending selfRef' <- pmatchC $ getField @"purpose" ctx + + selfRef <- tletField @"_0" selfRef' + let + selfInRef = getField @"outRef" selfIn + selfIdentity = selfRef #== selfInRef + + sigs = pfromData $ getField @"signatories" txInfo + validSignature = containsSignature # sigs # pkh + + validTime = pbefore # deadline # validRange + + rewardOut <- tlet $ pelemAt # rewardOutIx # outputs + rewardValue <- tlet $ getRewardValueByPKH' # rewardOut # pkh + let + vestingIn = assetClassValueOf # selfValue # vestingAC + vestingOut = assetClassValueOf # rewardValue # vestingAC + correctReward = vestingIn #== vestingOut + + pure $ validSignature #&& correctReward #&& validTime #&& selfIdentity \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/PContracts/PVestingWithPeriod.hs b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PVestingWithPeriod.hs new file mode 100644 index 00000000..68a10660 --- /dev/null +++ b/cardano-dex-contracts-onchain/ErgoDex/PContracts/PVestingWithPeriod.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE UndecidableInstances #-} + +module ErgoDex.PContracts.PVestingWithPeriod ( + VestingWithPeriodConfig (..), + vestingWithPeriodValidatorT +) where + +import qualified GHC.Generics as GHC + +import Plutarch +import Plutarch.List +import Plutarch.Api.V2 +import Plutarch.Extra.Interval +import Plutarch.Extra.Api +import Plutarch.DataRepr +import Plutarch.Lift +import Plutarch.Prelude +import Plutarch.Extra.TermCont + +import PExtra.API +import PExtra.Monadic (tlet, tletField) +import PExtra.Time + +import ErgoDex.PContracts.PApi +import Plutarch.Trace + +import qualified ErgoDex.Contracts.Proxy.VestingWithPeriod as VWP + +newtype VestingWithPeriodRedeemer (s :: S) + = VestingWithPeriodRedeemer + ( Term + s + ( PDataRecord + '[ "vestingInIx" ':= PInteger + , "vestingPeriodIdx" ':= PInteger + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType) + +instance DerivePlutusType VestingWithPeriodRedeemer where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl VestingWithPeriodRedeemer where type PLifted VestingWithPeriodRedeemer = VWP.VestingWithPeriodRedeemer +deriving via (DerivePConstantViaData VWP.VestingWithPeriodRedeemer VestingWithPeriodRedeemer) instance (PConstantDecl VWP.VestingWithPeriodRedeemer) + +newtype VestingWithPeriodConfig (s :: S) + = VestingConfig + ( Term + s + ( PDataRecord + '[ "vestingStart" ':= PPOSIXTime + , "vestingPeriodDuration" ':= PPOSIXTime + , "totalVested" ':= PInteger + , "periodVested" ':= PInteger + , "pkhs" ':= PBuiltinList (PAsData PPubKeyHash) + , "vestingAC" ':= PAssetClass + ] + ) + ) + deriving stock (GHC.Generic) + deriving + (PIsData, PDataFields, PlutusType, PEq) + +instance DerivePlutusType VestingWithPeriodConfig where type DPTStrat _ = PlutusTypeData + +instance PUnsafeLiftDecl VestingWithPeriodConfig where type PLifted VestingWithPeriodConfig = VWP.VestingWithPeriodConfig +deriving via (DerivePConstantViaData VWP.VestingWithPeriodConfig VestingWithPeriodConfig) instance (PConstantDecl VWP.VestingWithPeriodConfig) + +instance PTryFrom PData (PAsData VestingWithPeriodConfig) + +vestingWithPeriodValidatorT :: Term s PInteger -> Term s (VestingWithPeriodConfig :--> VestingWithPeriodRedeemer :--> PScriptContext :--> PBool) +vestingWithPeriodValidatorT threshold = plam $ \conf' redeemer' ctx' -> unTermCont $ do + ctx <- pletFieldsC @'["txInfo", "purpose"] ctx' + let txinfo' = getField @"txInfo" ctx + + conf <- pletFieldsC @'["vestingStart", "vestingPeriodDuration", "totalVested", "periodVested", "pkhs", "vestingAC"] conf' + redeemer <- pletFieldsC @'["vestingPeriodIdx", "vestingInIx"] redeemer' + txInfo <- pletFieldsC @'["validRange", "signatories", "inputs"] txinfo' + inputs <- tletUnwrap $ getField @"inputs" txInfo + let + vestingStart = pfromData $ getField @"vestingStart" conf + vestingPeriodDuration = pfromData $ getField @"vestingPeriodDuration" conf + + totalVested = pfromData $ getField @"totalVested" conf + periodVested = pfromData $ getField @"periodVested" conf + pkhs = pfromData $ getField @"pkhs" conf + vestingAC = pfromData $ getField @"vestingAC" conf + + vestingPeriodIdx = pfromData $ getField @"vestingPeriodIdx" redeemer + vestingInIdx = pfromData $ getField @"vestingInIx" redeemer + + sigs = pfromData $ getField @"signatories" txInfo + + validRange <- tletUnwrap $ getField @"validRange" txInfo + + selfIn' <- tlet $ pelemAt # vestingInIdx # inputs + selfIn <- pletFieldsC @'["outRef", "resolved"] selfIn' + let + periodAdditionalTime = pmultiply # vestingPeriodIdx # vestingPeriodDuration + + periodStartTime = periodAdditionalTime + vestingStart + validTime = pbefore # periodStartTime # validRange + + validSignaturesQty = + pfoldl # plam (\acc pkh -> pif (containsSignature' # sigs # pkh) (acc + 1) acc) # 0 # pkhs + + maxPeriodsQty = pdiv # totalVested # periodVested + isLastPeriod = maxPeriodsQty #<= vestingPeriodIdx + + self = getField @"resolved" selfIn + + selfAddr <- tletField @"address" self + + PSpending selfRef' <- pmatchC $ getField @"purpose" ctx + + selfRef <- tletField @"_0" selfRef' + let + selfInRef = getField @"outRef" selfIn + selfIdentity = selfRef #== selfInRef -- self is the output currently validated by this script + + validSignature <- tlet $ threshold #<= validSignaturesQty + + correctReward <- + tlet $ + isLastPeriod #|| (checkRewardAndDatumCorrectness # ctx' # conf' # totalVested # periodVested # vestingPeriodIdx # vestingAC # selfAddr) + pure $ validTime + #&& validSignature + #&& correctReward + #&& selfIdentity + +checkRewardAndDatumCorrectness :: Term s (PScriptContext :--> VestingWithPeriodConfig :--> PInteger :--> PInteger :--> PInteger :--> PAssetClass :--> PAddress :--> PBool) +checkRewardAndDatumCorrectness = + plam $ \ctx prevCfg totalVested periodVested periodId vestingAC selfAddr -> unTermCont $ do + let + selfOutputsList = getContinuingOutputs # ctx + selfOutput = phead # selfOutputsList + selfValue = pfield @"value" # selfOutput + txOutDatum <- tletField @"datum" selfOutput + succAddr <- tletField @"address" selfOutput + + POutputDatum txOutOutputDatum <- pmatchC txOutDatum + + rawDatum <- tletField @"outputDatum" txOutOutputDatum + + PDatum vestingDatumRaw <- pmatchC rawDatum + newVestingConfig <- tletUnwrap $ ptryFromData @(VestingWithPeriodConfig) $ vestingDatumRaw + let + correctOutQty = totalVested - (periodId * periodVested) + realOutQty = assetClassValueOf # selfValue # vestingAC + correctConfigs = prevCfg #== newVestingConfig + correctAddress = succAddr #== selfAddr + pure $ (realOutQty #== correctOutQty) #&& correctConfigs #&& correctAddress \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/ErgoDex/PValidators.hs b/cardano-dex-contracts-onchain/ErgoDex/PValidators.hs index ad882c29..215a5dac 100644 --- a/cardano-dex-contracts-onchain/ErgoDex/PValidators.hs +++ b/cardano-dex-contracts-onchain/ErgoDex/PValidators.hs @@ -3,17 +3,22 @@ module ErgoDex.PValidators ( swapValidator, depositValidator, redeemValidator, + vestingValidator, validatorAddress, + vestingWithPeriodValidator, wrapValidator, ) where import PlutusLedgerApi.V1.Scripts (Validator (getValidator)) import PlutusLedgerApi.V1.Address -import qualified ErgoDex.PContracts.PDeposit as PD -import qualified ErgoDex.PContracts.PPool as PP -import qualified ErgoDex.PContracts.PRedeem as PR -import qualified ErgoDex.PContracts.PSwap as PS +import qualified ErgoDex.PContracts.PDeposit as PD +import qualified ErgoDex.PContracts.PPool as PP +import qualified ErgoDex.PContracts.PRedeem as PR +import qualified ErgoDex.PContracts.PSwap as PS +import qualified ErgoDex.PContracts.PVesting as PV + +import qualified ErgoDex.PContracts.PVestingWithPeriod as PVWP import Plutarch import Plutarch.Api.V2 (mkValidator, validatorHash) @@ -23,7 +28,7 @@ import Plutarch.Unsafe (punsafeCoerce) import Plutarch.Internal cfgForValidator :: Config -cfgForValidator = Config NoTracing +cfgForValidator = Config DoTracingAndBinds wrapValidator :: (PIsData dt, PIsData rdmr) => @@ -47,5 +52,11 @@ depositValidator = mkValidator cfgForValidator $ wrapValidator PD.depositValidat redeemValidator :: Validator redeemValidator = mkValidator cfgForValidator $ wrapValidator PR.redeemValidatorT +vestingValidator :: Validator +vestingValidator = mkValidator cfgForValidator $ wrapValidator PV.vestingValidatorT + +vestingWithPeriodValidator :: Integer -> Validator +vestingWithPeriodValidator threshold = mkValidator cfgForValidator $ wrapValidator (PVWP.vestingWithPeriodValidatorT (pconstant threshold)) + validatorAddress :: Validator -> Address validatorAddress = scriptHashAddress . validatorHash diff --git a/cardano-dex-contracts-onchain/PExtra/Time.hs b/cardano-dex-contracts-onchain/PExtra/Time.hs new file mode 100644 index 00000000..21e15aa8 --- /dev/null +++ b/cardano-dex-contracts-onchain/PExtra/Time.hs @@ -0,0 +1,12 @@ +module PExtra.Time where + +import Plutarch.Prelude +import Plutarch +import Plutarch.Extra.Interval +import Plutarch.Api.V1.Time +import PExtra.Monadic (tmatch) + +pmultiply :: Term s (PInteger :--> PPOSIXTime :--> PPOSIXTime) +pmultiply = plam $ \n time -> unTermCont $ do + PPOSIXTime seconds <- tmatch time + pure $ pcon $ PPOSIXTime (seconds * n) \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/cardano-dex-contracts-onchain.cabal b/cardano-dex-contracts-onchain/cardano-dex-contracts-onchain.cabal index 865fbecf..e6af086d 100644 --- a/cardano-dex-contracts-onchain/cardano-dex-contracts-onchain.cabal +++ b/cardano-dex-contracts-onchain/cardano-dex-contracts-onchain.cabal @@ -91,6 +91,8 @@ library ErgoDex.Contracts.Proxy.Swap ErgoDex.Contracts.Proxy.Order ErgoDex.Contracts.Proxy.Redeem + ErgoDex.Contracts.Proxy.Vesting + ErgoDex.Contracts.Proxy.VestingWithPeriod ErgoDex.Contracts.Pool ErgoDex.PContracts.PApi ErgoDex.PContracts.PAssets @@ -103,10 +105,12 @@ library ErgoDex.PContracts.PStakingWithPkhLock ErgoDex.PContracts.PPoolStakeChangeMintPolicy ErgoDex.PStakingValidators + ErgoDex.PContracts.PVesting + ErgoDex.PContracts.PVestingWithPeriod ErgoDex.PMintingValidators ErgoDex.PValidators ErgoDex.PConstants - ErgoDex.Utils + PExtra.Time PExtra.Ada PExtra.API PExtra.Integer @@ -142,13 +146,16 @@ test-suite cardano-dex-contracts-test Gen.SwapGen Gen.RedeemGen Gen.DestroyGen + Gen.VestingGen + Gen.VestingWithPeriodGen Gen.Utils Tests.Deposit Tests.Pool Tests.Swap Tests.Redeem - Tests.Staking Tests.StakeMinting + Tests.Vesting + Tests.VestingWithPeriod Eval build-depends: , base diff --git a/cardano-dex-contracts-onchain/test/Gen/Models.hs b/cardano-dex-contracts-onchain/test/Gen/Models.hs index cc44be4a..fead73af 100644 --- a/cardano-dex-contracts-onchain/test/Gen/Models.hs +++ b/cardano-dex-contracts-onchain/test/Gen/Models.hs @@ -22,12 +22,15 @@ module Gen.Models , mkRedeemer , mkDatum , mkDatumHash + , mkOrderRedeemerRefund , mkMaxLq , mkTxInType , mkScriptCredential , genPkh , mkDepositValidator , mkSwapValidator + , mkVestingValidator + , mkVestingWithPeriodValidator , mkPoolValidator , mkTxOut , mkUserTxOut @@ -66,6 +69,7 @@ import qualified ErgoDex.PValidators as PScripts import qualified ErgoDex.Contracts.Pool as P import qualified ErgoDex.Contracts.Proxy.Deposit as D import qualified ErgoDex.Contracts.Proxy.Order as O +import qualified ErgoDex.Contracts.Proxy.Vesting as V import PlutusTx.Builtins as Builtins genBuiltinByteString :: MonadGen f => Int -> f BuiltinByteString @@ -96,7 +100,7 @@ genTokenName = do genCurrencySymbol :: MonadGen f => f CurrencySymbol genCurrencySymbol = do - bs <- random32bs + bs <- random28bs return $ CurrencySymbol bs mkAssetClass :: CurrencySymbol -> TokenName -> AssetClass @@ -136,6 +140,9 @@ mkDepositRedeemer a b c = O.OrderRedeemer a b c O.Apply mkOrderRedeemer :: Integer -> Integer -> Integer -> O.OrderRedeemer mkOrderRedeemer a b c = O.OrderRedeemer a b c O.Apply +mkOrderRedeemerRefund :: Integer -> Integer -> Integer -> O.OrderRedeemer +mkOrderRedeemerRefund a b c = O.OrderRedeemer a b c O.Refund + mkRedeemer :: ToData a => a -> Redeemer mkRedeemer = Redeemer . toBuiltinData @@ -166,6 +173,12 @@ mkPoolValidator = validatorHash PScripts.poolValidator mkSwapValidator :: ValidatorHash mkSwapValidator = validatorHash PScripts.swapValidator +mkVestingValidator :: ValidatorHash +mkVestingValidator = validatorHash PScripts.vestingValidator + +mkVestingWithPeriodValidator :: Integer -> ValidatorHash +mkVestingWithPeriodValidator threshold = validatorHash (PScripts.vestingWithPeriodValidator threshold) + mkTxOut :: OutputDatum -> Value -> ValidatorHash -> TxOut mkTxOut od v vh = TxOut diff --git a/cardano-dex-contracts-onchain/test/Gen/VestingGen.hs b/cardano-dex-contracts-onchain/test/Gen/VestingGen.hs new file mode 100644 index 00000000..78915d7c --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Gen/VestingGen.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Gen.VestingGen where + +import Hedgehog + +import Gen.Models +import Gen.DepositGen + +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Value +import PlutusLedgerApi.V2.Contexts +import PlutusLedgerApi.V1.Time +import PlutusLedgerApi.V1.Interval as PInterval + +import qualified ErgoDex.Contracts.Proxy.Vesting as V + +genVestingConfig :: Integer -> PubKeyHash -> AssetClass -> V.VestingConfig +genVestingConfig deadline vestingPkh vestingAC = + V.VestingConfig (POSIXTime deadline) vestingPkh vestingAC + +genTxInWithEmptyDatum :: TxOutRef -> Integer -> PubKeyHash -> TxInInfo +genTxInWithEmptyDatum txOutRef adaQty userPkh = + let + value = mkValues [mkAdaValue adaQty] mempty + txOut = mkTxOut' NoOutputDatum value userPkh + in mkTxIn txOutRef txOut + +genVestingTxIn :: TxOutRef -> OutputDatum -> AssetClass -> Integer -> TxInInfo +genVestingTxIn txOutRef vestingDatum vestingAC vestingTokenQty = + let + value = mkValues [mkValue vestingAC vestingTokenQty, mkAdaValue 1000] mempty + txOut = mkTxOut vestingDatum value mkVestingValidator + in mkTxIn txOutRef txOut + +genUserTxOut :: AssetClass -> Integer -> PubKeyHash -> TxOut +genUserTxOut vestingAC vestingTokenQty userPkh = + let + value = mkValues [mkAdaValue 1000, mkValue vestingAC vestingTokenQty] mempty + in mkTxOut' NoOutputDatum value userPkh + +mkVestingTxInfo :: [TxInInfo] -> [TxOut] -> Integer -> Integer -> PubKeyHash -> TxInfo +mkVestingTxInfo txIns txOuts validRangeStart validRangeEnd userPkh = + let + lower = (POSIXTime validRangeStart) + upper = (POSIXTime validRangeEnd) + in TxInfo + { txInfoInputs = txIns + , txInfoOutputs = txOuts + , txInfoReferenceInputs = mempty + , txInfoRedeemers = fromList [] + , txInfoFee = mempty + , txInfoMint = mempty + , txInfoDCert = [] + , txInfoWdrl = fromList [] + , txInfoValidRange = PInterval.interval lower upper --PInterval.Interval lower upper + , txInfoSignatories = [userPkh] + , txInfoData = fromList [] + , txInfoId = "b0" + } \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/test/Gen/VestingWithPeriodGen.hs b/cardano-dex-contracts-onchain/test/Gen/VestingWithPeriodGen.hs new file mode 100644 index 00000000..34c991b1 --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Gen/VestingWithPeriodGen.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Gen.VestingWithPeriodGen where + +import Hedgehog +import Hedgehog.Range +import Hedgehog.Gen + +import Gen.Models +import Gen.DepositGen + +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Value +import PlutusLedgerApi.V2.Contexts +import PlutusLedgerApi.V1.Time +import PlutusLedgerApi.V1.Interval as PInterval + +import ErgoDex.Contracts.Proxy.VestingWithPeriod + +genVestingWithPeriodConfig :: Integer -> Integer -> Integer -> Integer -> [PubKeyHash] -> AssetClass -> VestingWithPeriodConfig +genVestingWithPeriodConfig vestingStart vestingPeriodDuration totalVested periodVested signers vestingAC = + VestingWithPeriodConfig + { vestingStart = POSIXTime vestingStart + , vestingPeriodDuration = POSIXTime vestingPeriodDuration + , totalVested = totalVested + , periodVested = periodVested + , pkhs = signers + , vestingAC = vestingAC + } + +genVestingWPTxIn :: TxOutRef -> OutputDatum -> AssetClass -> Integer -> Integer -> TxInInfo +genVestingWPTxIn txOutRef vestingDatum vestingAC vestingTokenQty threshold = + let + value = mkValues [mkValue vestingAC vestingTokenQty, mkAdaValue 1000] mempty + txOut = mkTxOut vestingDatum value (mkVestingWithPeriodValidator threshold) + in mkTxIn txOutRef txOut + +genUserTxOut :: AssetClass -> Integer -> PubKeyHash -> TxOut +genUserTxOut vestingAC vestingTokenQty userPkh = + let + value = mkValues [mkValue vestingAC vestingTokenQty, mkAdaValue 1000] mempty + in mkTxOut' NoOutputDatum value userPkh + +genVestingWPTxOut :: OutputDatum -> AssetClass -> Integer -> Integer -> TxOut +genVestingWPTxOut vestingDatum vestingAC vestingTokenQty threshold = + let + value = mkValues [mkValue vestingAC vestingTokenQty, mkAdaValue 1000] mempty + in mkTxOut vestingDatum value (mkVestingWithPeriodValidator threshold) + +mkVestingTxInfo :: [TxInInfo] -> [TxOut] -> Integer -> Integer -> [PubKeyHash] -> TxInfo +mkVestingTxInfo txIns txOuts validRangeStart validRangeEnd signers = + let + lower = (POSIXTime validRangeStart) + upper = (POSIXTime validRangeEnd) + in TxInfo + { txInfoInputs = txIns + , txInfoOutputs = txOuts + , txInfoReferenceInputs = mempty + , txInfoRedeemers = fromList [] + , txInfoFee = mempty + , txInfoMint = mempty + , txInfoDCert = [] + , txInfoWdrl = fromList [] + , txInfoValidRange = PInterval.interval lower upper --PInterval.Interval lower upper + , txInfoSignatories = signers + , txInfoData = fromList [] + , txInfoId = "b0" + } \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/test/Spec.hs b/cardano-dex-contracts-onchain/test/Spec.hs index e9d51d02..eb8b584b 100644 --- a/cardano-dex-contracts-onchain/test/Spec.hs +++ b/cardano-dex-contracts-onchain/test/Spec.hs @@ -2,12 +2,13 @@ module Main(main) where import ErgoDex.PMintingValidators -import Tests.Deposit +import Tests.Deposit import Tests.Pool import Tests.Swap import Tests.Redeem -import Tests.Staking -import Tests.StakeMinting +import Tests.StakeMinting +import Tests.Vesting +import Tests.VestingWithPeriod import Test.Tasty import Test.Tasty.HUnit @@ -37,5 +38,7 @@ tests = testGroup "Contracts" , checkSwap , checkSwapRedeemer , checkSwapIdentity + , checkVesting + , checkVestingWithPeriod , checkPkhLockStaking ] \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/test/Tests/StakeMinting.hs b/cardano-dex-contracts-onchain/test/Tests/StakeMinting.hs index 29fbf0be..8f9e3dde 100644 --- a/cardano-dex-contracts-onchain/test/Tests/StakeMinting.hs +++ b/cardano-dex-contracts-onchain/test/Tests/StakeMinting.hs @@ -26,7 +26,7 @@ import ErgoDex.PConstants import Eval import Gen.Models -import Gen.DepositGen +import Gen.DepositGen hiding (mkByteString) import Gen.PoolGen import Gen.SwapGen import Gen.RedeemGen diff --git a/cardano-dex-contracts-onchain/test/Tests/Vesting.hs b/cardano-dex-contracts-onchain/test/Tests/Vesting.hs new file mode 100644 index 00000000..22109bc0 --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Tests/Vesting.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Vesting where + +import qualified ErgoDex.PContracts.PVesting as PVesting +import qualified ErgoDex.Contracts.Proxy.Vesting as PPVesting +import ErgoDex.PValidators + +import Eval +import Gen.Utils +import Gen.VestingGen + +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Time + +import Hedgehog + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog as HH +import Hedgehog.Range +import Hedgehog.Gen + +import Gen.Models + +checkVesting = testGroup "CheckVesting" + [ HH.testProperty "correct_vesting" correctVesting + , HH.testProperty "incorrect_signature_vesting" incorrectSignatureVesting + , HH.testProperty "incorrect_deadline_vesting" incorrectDeadlineVesting + , HH.testProperty "incorrect_vesting_input_idx" incorrectVestingInIdx + , HH.testProperty "incorrect_vesting_reward_idx" incorrectVestingRewardIdx + ] + +correctVesting :: Property +correctVesting = property $ do + let + range = exponential 10 512 + pkh <- forAll genPkh + vestingOutTxRef <- forAll genTxOutRef + vestingAC <- forAll genAssetClass + deadlineInt <- forAll $ int range + let + deadline = toInteger deadlineInt + + vestingCfg = genVestingConfig deadline pkh vestingAC + vestingCfgData = toData vestingCfg + vestingDatum = OutputDatum $ mkDatum vestingCfg + vestingTxIn = genVestingTxIn vestingOutTxRef vestingDatum vestingAC 10 + userTxOut = genUserTxOut vestingAC 10 pkh + + txInfo = mkVestingTxInfo [vestingTxIn] [userTxOut] (deadline + 5) (deadline + 10) pkh + purpose = mkPurpose vestingOutTxRef + + cxtData = toData $ mkContext txInfo purpose + vestingRedeemToData = toData $ PPVesting.VestingRedeemer 0 0 + + result = eraseRight $ evalWithArgs (wrapValidator PVesting.vestingValidatorT) [vestingCfgData, vestingRedeemToData, cxtData] + result === Right () + +incorrectSignatureVesting :: Property +incorrectSignatureVesting = property $ do + let + range = exponential 10 512 + pkh <- forAll genPkh + incorrectPkh <- forAll genPkh + vestingOutTxRef <- forAll genTxOutRef + vestingAC <- forAll genAssetClass + deadlineInt <- forAll $ int range + let + deadline = toInteger deadlineInt + + vestingCfg = genVestingConfig deadline pkh vestingAC + vestingCfgData = toData vestingCfg + vestingDatum = OutputDatum $ mkDatum vestingCfg + vestingTxIn = genVestingTxIn vestingOutTxRef vestingDatum vestingAC 10 + userTxOut = genUserTxOut vestingAC 10 pkh + + txInfo = mkVestingTxInfo [vestingTxIn] [userTxOut] (deadline + 5) (deadline + 10) incorrectPkh + purpose = mkPurpose vestingOutTxRef + + cxtData = toData $ mkContext txInfo purpose + vestingRedeemToData = toData $ PPVesting.VestingRedeemer 0 0 + + result = eraseLeft $ evalWithArgs (wrapValidator PVesting.vestingValidatorT) [vestingCfgData, vestingRedeemToData, cxtData] + result === Left () + +incorrectDeadlineVesting :: Property +incorrectDeadlineVesting = property $ do + let + range = exponential 10 512 + pkh <- forAll genPkh + vestingOutTxRef <- forAll genTxOutRef + vestingAC <- forAll genAssetClass + deadlineInt <- forAll $ int range + let + deadline = toInteger deadlineInt + + vestingCfg = genVestingConfig deadline pkh vestingAC + vestingCfgData = toData vestingCfg + vestingDatum = OutputDatum $ mkDatum vestingCfg + vestingTxIn = genVestingTxIn vestingOutTxRef vestingDatum vestingAC 10 + userTxOut = genUserTxOut vestingAC 10 pkh + + txInfo = mkVestingTxInfo [vestingTxIn] [userTxOut] (deadline - 10) (deadline - 5) pkh + purpose = mkPurpose vestingOutTxRef + + cxtData = toData $ mkContext txInfo purpose + vestingRedeemToData = toData $ PPVesting.VestingRedeemer 0 0 + + result = eraseLeft $ evalWithArgs (wrapValidator PVesting.vestingValidatorT) [vestingCfgData, vestingRedeemToData, cxtData] + result === Left () + +incorrectVestingInIdx :: Property +incorrectVestingInIdx = property $ do + let + range = exponential 10 512 + pkh <- forAll genPkh + vestingOutTxRef <- forAll genTxOutRef + userOutTxRef <- forAll genTxOutRef + vestingAC <- forAll genAssetClass + deadlineInt <- forAll $ int range + let + deadline = toInteger deadlineInt + + vestingCfg = genVestingConfig deadline pkh vestingAC + vestingCfgData = toData vestingCfg + vestingDatum = OutputDatum $ mkDatum vestingCfg + vestingTxIn = genVestingTxIn vestingOutTxRef vestingDatum vestingAC 10 + userTxIn = genTxInWithEmptyDatum userOutTxRef 100 pkh + userTxOut = genUserTxOut vestingAC 10 pkh + + txInfo = mkVestingTxInfo [userTxIn, vestingTxIn] [userTxOut] (deadline + 5) (deadline + 10) pkh + purpose = mkPurpose vestingOutTxRef + + cxtData = toData $ mkContext txInfo purpose + vestingRedeemToData = toData $ PPVesting.VestingRedeemer 0 0 + + result = eraseLeft $ evalWithArgs (wrapValidator PVesting.vestingValidatorT) [vestingCfgData, vestingRedeemToData, cxtData] + result === Left () + +incorrectVestingRewardIdx :: Property +incorrectVestingRewardIdx = property $ do + let + range = exponential 10 512 + pkh <- forAll genPkh + vestingOutTxRef <- forAll genTxOutRef + userOutTxRef <- forAll genTxOutRef + vestingAC <- forAll genAssetClass + deadlineInt <- forAll $ int range + let + deadline = toInteger deadlineInt + + vestingCfg = genVestingConfig deadline pkh vestingAC + vestingCfgData = toData vestingCfg + vestingDatum = OutputDatum $ mkDatum vestingCfg + vestingTxIn = genVestingTxIn vestingOutTxRef vestingDatum vestingAC 10 + userTxOut = genUserTxOut vestingAC 10 pkh + + userTxOutWithIncorrectValue = genUserTxOut vestingAC 50 pkh + + txInfo = mkVestingTxInfo [vestingTxIn] [userTxOutWithIncorrectValue, userTxOut] (deadline + 5) (deadline + 10) pkh + purpose = mkPurpose vestingOutTxRef + + cxtData = toData $ mkContext txInfo purpose + vestingRedeemToData = toData $ PPVesting.VestingRedeemer 0 0 + + result = eraseLeft $ evalWithArgs (wrapValidator PVesting.vestingValidatorT) [vestingCfgData, vestingRedeemToData, cxtData] + result === Left () \ No newline at end of file diff --git a/cardano-dex-contracts-onchain/test/Tests/VestingWithPeriod.hs b/cardano-dex-contracts-onchain/test/Tests/VestingWithPeriod.hs new file mode 100644 index 00000000..f10c04cd --- /dev/null +++ b/cardano-dex-contracts-onchain/test/Tests/VestingWithPeriod.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Tests.VestingWithPeriod where + +import qualified ErgoDex.PContracts.PVestingWithPeriod as PVestingWP +import qualified ErgoDex.Contracts.Proxy.VestingWithPeriod as PPVestingWP +import ErgoDex.PValidators + +import Eval +import Gen.Utils +import Gen.VestingWithPeriodGen + +import Plutarch.Prelude +import PlutusLedgerApi.V2 +import PlutusLedgerApi.V1.Time + +import Hedgehog + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog as HH +import Hedgehog.Range +import Hedgehog.Gen + +import Prelude +import Data.Either + +import Gen.Models +import Debug.Trace + +checkVestingWithPeriod = testGroup "checkVestingWithPeriod" + [ HH.testProperty "correct_vesting" correctVesting + , HH.testProperty "incorrect_signature_qty_vesting" incorrectSignatureQtyVesting + , HH.testProperty "incorrect_time_vesting" incorrectTimeVesting + , HH.testProperty "incorrect_value_vesting" incorrectValueVesting + , HH.testProperty "incorrect_datum_in_output" incorrectDatumVesting + ] + +correctVesting :: Property +correctVesting = property $ do + let + range = linear 24 4096 + firstPkh <- forAll genPkh + secondPkh <- forAll genPkh + vestingOutTxRef <- forAll genTxOutRef + vestingAC <- forAll genAssetClass + vestingStartInt <- (forAll $ int range) + + vestingPeriodDurationInt <- forAll $ int range + + totalVestedInt <- forAll $ int range + periodVetedInt <- forAll $ int range + let + vestingStart = toInteger vestingStartInt + + vestingPeriodDuration = toInteger vestingPeriodDurationInt + + totalVested = toInteger totalVestedInt + periodVested = toInteger periodVetedInt + + maxPeriodId = totalVested `div` periodVested + + vestingWPCfg = genVestingWithPeriodConfig vestingStart vestingPeriodDuration totalVested periodVested [firstPkh, secondPkh] vestingAC + vestingWPCfgData = toData vestingWPCfg + vestingWPDatum = OutputDatum $ mkDatum vestingWPCfg + initialVestingWPTxIn = genVestingWPTxIn vestingOutTxRef vestingWPDatum vestingAC totalVested 2 + periodsList = [1..maxPeriodId] + + (_, result) = + foldl (\(vestingBox, prevResult) periodId -> do + let + deadline = vestingStart + vestingPeriodDuration * periodId + + vestingRedeemToData = toData $ PPVestingWP.VestingWithPeriodRedeemer 0 periodId + + newVestingBox = genVestingWPTxOut vestingWPDatum vestingAC (totalVested - periodId * periodVested) 2 + + newVestingBoxInput = mkTxIn vestingOutTxRef newVestingBox + + toVest = if (periodId == maxPeriodId) then (totalVested - periodId * periodVested) else periodVested + + userTxOut = genUserTxOut vestingAC toVest firstPkh + + txInfo = + if (periodId == maxPeriodId) + then mkVestingTxInfo [vestingBox] [userTxOut] (deadline + 5) (deadline + 10) [firstPkh, secondPkh] + else mkVestingTxInfo [vestingBox] [newVestingBox, userTxOut] (deadline + 5) (deadline + 10) [firstPkh, secondPkh] + + purpose = mkPurpose vestingOutTxRef + + cxtData = toData $ mkContext txInfo purpose + + resultEither = eraseRight $ evalWithArgs (wrapValidator (PVestingWP.vestingWithPeriodValidatorT (pconstant 2))) [vestingWPCfgData, vestingRedeemToData, cxtData] + + in (newVestingBoxInput, prevResult && isRight resultEither) + ) (initialVestingWPTxIn, True) periodsList + + result === True + +incorrectSignatureQtyVesting :: Property +incorrectSignatureQtyVesting = property $ do + let + range = linear 24 4096 + firstPkh <- forAll genPkh + secondPkh <- forAll genPkh + vestingOutTxRef <- forAll genTxOutRef + vestingAC <- forAll genAssetClass + vestingStartInt <- (forAll $ int range) + + vestingPeriodDurationInt <- forAll $ int range + + totalVestedInt <- forAll $ int range + let + vestedRange = linear 24 totalVestedInt + + maxPeriodIdInt <- forAll $ int vestedRange + let + + vestingStart = toInteger vestingStartInt + + vestingPeriodDuration = toInteger vestingPeriodDurationInt + + totalVested = toInteger totalVestedInt + maxPeriodId = toInteger maxPeriodIdInt + + periodVested = totalVested `div` maxPeriodId + + vestingWPCfg = genVestingWithPeriodConfig vestingStart vestingPeriodDuration totalVested periodVested [firstPkh, secondPkh] vestingAC + vestingWPCfgData = toData vestingWPCfg + vestingWPDatum = OutputDatum $ mkDatum vestingWPCfg + initialVestingWPTxIn = genVestingWPTxIn vestingOutTxRef vestingWPDatum vestingAC totalVested 2 + periodsList = [1..maxPeriodId] + + let + (_, result) = + foldl (\(vestingBox, prevResult) periodId -> + let + deadline = vestingStart + vestingPeriodDuration * periodId + + vestingRedeemToData = toData $ PPVestingWP.VestingWithPeriodRedeemer 0 periodId + + newVestingBox = genVestingWPTxOut vestingWPDatum vestingAC (totalVested - periodId * periodVested) 2 + + newVestingBoxInput = mkTxIn vestingOutTxRef newVestingBox + + userTxOut = genUserTxOut vestingAC periodVested firstPkh + + txInfo = + if (periodId == maxPeriodId) + then mkVestingTxInfo [vestingBox] [userTxOut] (deadline + 5) (deadline + 10) [secondPkh] + else mkVestingTxInfo [vestingBox] [newVestingBox, userTxOut] (deadline + 5) (deadline + 10) [secondPkh] + + purpose = mkPurpose vestingOutTxRef + + cxtData = toData $ mkContext txInfo purpose + + resultEither = eraseRight $ evalWithArgs (wrapValidator (PVestingWP.vestingWithPeriodValidatorT (pconstant 2))) [vestingWPCfgData, vestingRedeemToData, cxtData] + + in (newVestingBoxInput, prevResult && isRight resultEither) + ) (initialVestingWPTxIn, True) periodsList + + result === False + +incorrectTimeVesting :: Property +incorrectTimeVesting = property $ do + let + range = linear 24 4096 + firstPkh <- forAll genPkh + secondPkh <- forAll genPkh + vestingOutTxRef <- forAll genTxOutRef + vestingAC <- forAll genAssetClass + vestingStartInt <- (forAll $ int range) + + vestingPeriodDurationInt <- forAll $ int range + + totalVestedInt <- forAll $ int range + let + vestedRange = linear 24 totalVestedInt + + maxPeriodIdInt <- forAll $ int vestedRange + let + + vestingStart = toInteger vestingStartInt + + vestingPeriodDuration = toInteger vestingPeriodDurationInt + + totalVested = toInteger totalVestedInt + maxPeriodId = toInteger maxPeriodIdInt + + periodVested = totalVested `div` maxPeriodId + + vestingWPCfg = genVestingWithPeriodConfig vestingStart vestingPeriodDuration totalVested periodVested [firstPkh, secondPkh] vestingAC + vestingWPCfgData = toData vestingWPCfg + vestingWPDatum = OutputDatum $ mkDatum vestingWPCfg + initialVestingWPTxIn = genVestingWPTxIn vestingOutTxRef vestingWPDatum vestingAC totalVested 1 + periodsList = [1..maxPeriodId] + let + (_, result) = + foldl (\(vestingBox, prevResult) periodId -> + let + + deadline = vestingStart + vestingPeriodDuration * periodId + + vestingRedeemToData = toData $ PPVestingWP.VestingWithPeriodRedeemer 0 periodId + + newVestingBox = genVestingWPTxOut vestingWPDatum vestingAC (totalVested - periodId * periodVested) 1 + + newVestingBoxInput = mkTxIn vestingOutTxRef newVestingBox + + userTxOut = genUserTxOut vestingAC (periodVested) firstPkh + + txInfo = + if (periodId == maxPeriodId) + then mkVestingTxInfo [vestingBox] [userTxOut] (deadline - 5) (deadline + 5) [firstPkh, secondPkh] + else mkVestingTxInfo [vestingBox] [newVestingBox, userTxOut] (deadline - 5) (deadline + 5) [secondPkh] + + purpose = mkPurpose vestingOutTxRef + + cxtData = toData $ mkContext txInfo purpose + + resultEither = eraseRight $ evalWithArgs (wrapValidator (PVestingWP.vestingWithPeriodValidatorT (pconstant 1))) [vestingWPCfgData, vestingRedeemToData, cxtData] + + in (newVestingBoxInput, prevResult && isRight resultEither) + ) (initialVestingWPTxIn, True) periodsList + + result === False + +incorrectValueVesting :: Property +incorrectValueVesting = property $ do + let + range = linear 24 4096 + firstPkh <- forAll genPkh + secondPkh <- forAll genPkh + vestingOutTxRef <- forAll genTxOutRef + vestingAC <- forAll genAssetClass + vestingStartInt <- (forAll $ int range) + + vestingPeriodDurationInt <- forAll $ int range + + totalVestedInt <- forAll $ int range + let + vestedRange = linear 24 totalVestedInt + + maxPeriodIdInt <- forAll $ int vestedRange + let + + vestingStart = toInteger vestingStartInt + + vestingPeriodDuration = toInteger vestingPeriodDurationInt + + totalVested = toInteger totalVestedInt + maxPeriodId = toInteger maxPeriodIdInt + + periodVested = totalVested `div` maxPeriodId + + vestingWPCfg = genVestingWithPeriodConfig vestingStart vestingPeriodDuration totalVested periodVested [firstPkh, secondPkh] vestingAC + vestingWPCfgData = toData vestingWPCfg + vestingWPDatum = OutputDatum $ mkDatum vestingWPCfg + initialVestingWPTxIn = genVestingWPTxIn vestingOutTxRef vestingWPDatum vestingAC totalVested 1 + periodsList = [1..maxPeriodId] + let + (_, result) = + foldl (\(vestingBox, prevResult) periodId -> + let + deadline = vestingStart + vestingPeriodDuration * periodId + + vestingRedeemToData = toData $ PPVestingWP.VestingWithPeriodRedeemer 0 periodId + + newVestingBox = + if (totalVested - periodId * periodVested >= 10) + then genVestingWPTxOut vestingWPDatum vestingAC (totalVested - periodId * periodVested - 10) 1 + else genVestingWPTxOut vestingWPDatum vestingAC (totalVested - periodId * periodVested) 1 + + newVestingBoxInput = mkTxIn vestingOutTxRef newVestingBox + + userTxOut = genUserTxOut vestingAC (periodVested + 10) firstPkh + + txInfo = + if (periodId == maxPeriodId) + then mkVestingTxInfo [vestingBox] [userTxOut] (deadline + 5) (deadline + 10) [firstPkh, secondPkh] + else mkVestingTxInfo [vestingBox] [newVestingBox, userTxOut] (deadline + 5) (deadline + 10) [secondPkh] + + purpose = mkPurpose vestingOutTxRef + + cxtData = toData $ mkContext txInfo purpose + + resultEither = eraseRight $ evalWithArgs (wrapValidator (PVestingWP.vestingWithPeriodValidatorT (pconstant 1))) [vestingWPCfgData, vestingRedeemToData, cxtData] + + in (newVestingBoxInput, prevResult && isRight resultEither) + ) (initialVestingWPTxIn, True) periodsList + + result === False + +incorrectDatumVesting :: Property +incorrectDatumVesting = property $ do + let + range = linear 24 4096 + firstPkh <- forAll genPkh + secondPkh <- forAll genPkh + vestingOutTxRef <- forAll genTxOutRef + vestingAC <- forAll genAssetClass + vestingStartInt <- (forAll $ int range) + + vestingPeriodDurationInt <- forAll $ int range + + totalVestedInt <- forAll $ int range + let + vestedRange = linear 24 totalVestedInt + + maxPeriodIdInt <- forAll $ int vestedRange + let + + vestingStart = toInteger vestingStartInt + + vestingPeriodDuration = toInteger vestingPeriodDurationInt + + totalVested = toInteger totalVestedInt + maxPeriodId = toInteger maxPeriodIdInt + + periodVested = totalVested `div` maxPeriodId + periodId = 1 + + vestingWPCfg = genVestingWithPeriodConfig vestingStart vestingPeriodDuration totalVested periodVested [firstPkh, secondPkh] vestingAC + vestingWPCfgData = toData vestingWPCfg + vestingWPDatum = OutputDatum $ mkDatum vestingWPCfg + initialVestingWPTxIn = genVestingWPTxIn vestingOutTxRef vestingWPDatum vestingAC totalVested 1 + periodsList = [1..maxPeriodId] + + deadline = vestingStart + vestingPeriodDuration * periodId + + vestingRedeemToData = toData $ PPVestingWP.VestingWithPeriodRedeemer 0 periodId + + newVestingBox = genVestingWPTxOut NoOutputDatum vestingAC (totalVested - periodId * periodVested) 1 + + userTxOut = genUserTxOut vestingAC periodVested firstPkh + txInfo = mkVestingTxInfo [initialVestingWPTxIn] [newVestingBox, userTxOut] (deadline + 5) (deadline + 10) [secondPkh] + purpose = mkPurpose vestingOutTxRef + cxtData = toData $ mkContext txInfo purpose + resultEither = eraseLeft $ evalWithArgs (wrapValidator (PVestingWP.vestingWithPeriodValidatorT (pconstant 1))) [vestingWPCfgData, vestingRedeemToData, cxtData] + + resultEither === Left () \ No newline at end of file diff --git a/docs/VestingWithPeriod.md b/docs/VestingWithPeriod.md new file mode 100644 index 00000000..61de7cc0 --- /dev/null +++ b/docs/VestingWithPeriod.md @@ -0,0 +1,36 @@ +# Spectrum Finance Vesting with period protocol + +The Vesting with Period Protocol enables individuals to create their own customized vesting programs. + +### Datum (Vesting configuration) + +| Field | Type | Description | +| ----------------------- | ------------------- | ----------------------------------- | +| `vestingStart` | `POSIXTime` | Time of program start | +| `vestingPeriodDuration` | `POSIXTime` | Period duration | +| `totalVested` | `Integer` | Program budget | +| `periodVested` | `Integer` | Period budget | +| `pkhs` | `List[PPubKeyHash]` | List of authority members | +| `vestingAC` | `AssetClass` | Program budget token (e.g ADA, SPF) | + +### Redeemer (Withdraw part) + +| Field | Type | Description | +| ------------------ | --------- | ---------------------------------------- | +| `vestingInIx` | `Integer` | Index of box with vesting program budget | +| `vestingPeriodIdx` | `Integer` | Index of period, that should be unlocked | + +### Tokens + +| Name | Description | +| -------------------- | ----------------------------------------------------- | +| Program budget token | Token that will be distributed during vesting program | + +## User scenarios + +### Vesting program creation +Alice implemented a vesting program (Program X) and aims to incentivize workers. She introduces a vesting program for a duration of 1 year with a 3-month unlock period. To achieve this, Alice initializes the following parameters: vestingStart to the current time, vestingPeriodDuration set as 3 months, totalVested representing the program budget, pkhs denoting the list of workers' public keys, and vestingAC as the AssetClass of token Xt. Subsequently, Alice sends totalVested tokens Xt along with the corresponding datum to the address of the "Vesting with period" script. + +### Vesting program withdraw +To retrieve tokens from the vesting program, users should wait until the specified period ends. The period duration is calculated as (vestingStart + periodId * vestingPeriodDuration). Once the period has ended, users can interact with the vesting program box by creating a transaction. The transaction should include the following parameters: vestingInIx (representing the index of the vesting box in the inputs list) and vestingPeriodIdx (representing the period ID) in redeemer. +In addition, the transaction should be signed by all private keys corresponding to the public key hashes from pkhs.