Dev 285. Vesting contracts

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

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

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

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
             }

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)

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

cardano-dex-contracts-offchain/cardano-dex-contracts-offchain.cabal

@@ -15,7 +15,7 @@ license:       CC0-1.0
 license-files: LICENSE
 author:        ErgoLabs
 maintainer:    [email protected]
-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

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)
+

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)]
+

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)]
+

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

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