├── .gitignore ├── test ├── Main.hs ├── Tests │ ├── Tests.hs │ ├── OnChain │ │ ├── Feed.hs │ │ ├── Claim.hs │ │ ├── Compound.hs │ │ ├── Deposit.hs │ │ └── Withdraw.hs │ ├── OffChain │ │ ├── UseCaseTests.hs │ │ ├── Start.hs │ │ ├── Feed.hs │ │ ├── Register.hs │ │ ├── Deposit.hs │ │ ├── Claim.hs │ │ ├── Compound.hs │ │ ├── Withdraw.hs │ │ └── Unregister.hs │ ├── Attacks │ │ ├── Feed.hs │ │ ├── AttackUtils.hs │ │ ├── Claim.hs │ │ ├── Compound.hs │ │ ├── Deposit.hs │ │ └── Withdraw.hs │ ├── TestUtils.hs │ └── BusinessTests.hs └── BCExplorer.hs ├── src ├── Staking │ ├── Tokens.hs │ ├── Business.hs │ ├── Business │ │ ├── Pool.hs │ │ ├── Types.hs │ │ └── User.hs │ ├── Validator.hs │ ├── Types.hs │ └── OffChain.hs ├── Staking.hs ├── MainToken.hs └── Utils │ ├── OffChain.hs │ └── ScriptContext.hs ├── staking-pool-sc.cabal ├── README.md └── cabal.project /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | .HTF/ 22 | .ghc.environment.* 23 | *~ 24 | *.lock 25 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Main 3 | Description : The main tests file that calls every test with one command. 4 | Copyright : P2P Solutions Ltd. 5 | License : GPL-3 6 | Maintainer : laurynas@adafinance.io 7 | Stability : develop 8 | -} 9 | 10 | module Main ( main ) where 11 | 12 | import Test.Tasty (defaultMain) 13 | 14 | import Tests.Tests (tests) 15 | 16 | main :: IO () 17 | main = defaultMain tests 18 | -------------------------------------------------------------------------------- /src/Staking/Tokens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | {-| 4 | Module : Staking.Tokens 5 | Description : Name of the StakingNFT and UserNFT tokens. 6 | Copyright : P2P Solutions Ltd. 7 | License : GPL-3 8 | Maintainer : laurynas@adafinance.io 9 | Stability : develop 10 | -} 11 | 12 | module Staking.Tokens where 13 | 14 | import Ledger 15 | 16 | stakingNFTName :: TokenName 17 | stakingNFTName = "Staking" 18 | 19 | userNFTName :: TokenName 20 | userNFTName = "User" 21 | -------------------------------------------------------------------------------- /src/Staking.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Staking 3 | Description : Main module of the Staking Pool contract. 4 | Copyright : P2P Solutions Ltd. 5 | License : GPL-3 6 | Maintainer : laurynas@adafinance.io 7 | Stability : develop 8 | -} 9 | 10 | module Staking 11 | ( module Staking.Business 12 | , module Staking.OffChain 13 | , module Staking.OnChain 14 | , module Staking.Tokens 15 | , module Staking.Types 16 | , module Staking.Validator 17 | ) 18 | where 19 | 20 | import Staking.Business 21 | import Staking.OffChain 22 | import Staking.OnChain 23 | import Staking.Tokens 24 | import Staking.Types 25 | import Staking.Validator 26 | -------------------------------------------------------------------------------- /src/Staking/Business.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE NumericUnderscores #-} 3 | 4 | {-| 5 | Module : Staking.Business 6 | Description : Main module of Business logic. 7 | Copyright : P2P Solutions Ltd. 8 | License : GPL-3 9 | Maintainer : laurynas@adafinance.io 10 | Stability : develop 11 | -} 12 | 13 | module Staking.Business 14 | ( 15 | -- ^ Main User functions 16 | claim 17 | , compound 18 | , deposit 19 | , withdraw 20 | -- ^ Main Pool functions 21 | , register 22 | , unregister 23 | -- ^ Utils 24 | , validTimeRange 25 | , isAfter 26 | , getUserNFT 27 | , isRegistered 28 | , module Staking.Business.Types 29 | ) where 30 | 31 | -- Third-party libraries. 32 | import Ledger 33 | 34 | -- Internal modules. 35 | import Staking.Business.Pool 36 | import Staking.Business.User 37 | import Staking.Business.Types 38 | 39 | validTimeRange :: POSIXTime 40 | validTimeRange = POSIXTime 10_000 41 | -------------------------------------------------------------------------------- /src/Staking/Business/Pool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | {-| 5 | Module : Staking.Business.Pool 6 | Description : Business logic related to registration of users in 7 | the staking pool. 8 | Copyright : P2P Solutions Ltd. 9 | License : GPL-3 10 | Maintainer : laurynas@adafinance.io 11 | Stability : develop 12 | -} 13 | 14 | module Staking.Business.Pool where 15 | 16 | -- Third-party libraries. 17 | import Ledger 18 | import PlutusTx.Prelude 19 | 20 | -- Internal modules. 21 | import Staking.Business.Types 22 | 23 | 24 | {-# INLINABLE register #-} 25 | register :: PoolState -> PubKeyHash -> AssetClass -> PoolState 26 | register PoolState{..} pkh ac = mkPoolState $ (pkh, ac) : activeUsers 27 | 28 | {-# INLINABLE unregister #-} 29 | unregister :: PoolState -> PubKeyHash -> PoolState 30 | unregister PoolState{..} pkh = mkPoolState $ filter ((pkh /=) . fst) activeUsers 31 | 32 | {-# INLINABLE isRegistered #-} 33 | isRegistered :: PubKeyHash -> PoolState -> Bool 34 | isRegistered pkh PoolState{..} = 35 | activeUsers /= filter ((pkh /=) . fst) activeUsers 36 | 37 | {-# INLINABLE getUserNFT #-} 38 | getUserNFT :: PoolState -> PubKeyHash -> Maybe AssetClass 39 | getUserNFT PoolState{..} pkh = snd <$> find ((== pkh) . fst) activeUsers 40 | 41 | {-# INLINABLE isOneElemExtensionOf #-} 42 | isOneElemExtensionOf :: PoolState -> PoolState -> Bool 43 | isOneElemExtensionOf ps1 ps2 = 44 | all ((`isRegistered` ps1) . fst) (activeUsers ps2) 45 | && length (activeUsers ps2) + 1 == length (activeUsers ps1) 46 | -------------------------------------------------------------------------------- /src/MainToken.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | 9 | {-| 10 | Module : MainToken 11 | Description : Description of the token used by the staking pool. 12 | Copyright : P2P Solutions Ltd. 13 | License : GPL-3 14 | Maintainer : laurynas@adafinance.io 15 | Stability : develop 16 | -} 17 | 18 | module MainToken where 19 | 20 | -- GHC libraries. 21 | import Data.Aeson (FromJSON, ToJSON) 22 | import GHC.Generics (Generic) 23 | import qualified Prelude as HP (Show (..), Eq (..)) 24 | 25 | -- Third-party libraries. 26 | import Ledger 27 | import Ledger.Value 28 | import qualified PlutusTx 29 | import PlutusTx.Prelude 30 | 31 | newtype MainToken = MicroToken { getMicroToken :: Integer } 32 | deriving (HP.Eq, HP.Show, Generic) 33 | deriving anyclass (FromJSON, ToJSON) 34 | 35 | -- Boilerplate. 36 | instance Eq MainToken where 37 | {-# INLINABLE (==) #-} 38 | am1 == am2 = getMicroToken am1 == getMicroToken am2 39 | 40 | mainTokenSymbol :: CurrencySymbol 41 | mainTokenSymbol = "ff" 42 | 43 | mainToken :: TokenName 44 | mainToken = "MyToken" 45 | 46 | mainTokenAC :: AssetClass 47 | mainTokenAC = AssetClass (mainTokenSymbol, mainToken) 48 | 49 | {-# INLINABLE mainTokenValue #-} 50 | mainTokenValue :: Integer -> Value 51 | mainTokenValue = assetClassValue mainTokenAC 52 | 53 | PlutusTx.unstableMakeIsData ''MainToken 54 | -------------------------------------------------------------------------------- /src/Staking/Validator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE DataKinds #-} 5 | 6 | {-| 7 | Module : Staking.Validator 8 | Description : Boilerplate for compiling the plutus onchain code. 9 | Copyright : P2P Solutions Ltd. 10 | License : GPL-3 11 | Maintainer : laurynas@adafinance.io 12 | Stability : develop 13 | -} 14 | 15 | module Staking.Validator 16 | ( validatorStaking 17 | , typedValidatorStaking 18 | , addressStaking 19 | , StakingType 20 | ) where 21 | 22 | import Ledger 23 | import qualified Ledger.Typed.Scripts as Scripts 24 | import PlutusTx 25 | 26 | import MainToken 27 | import Staking.Types 28 | import Staking.OnChain 29 | 30 | data StakingType 31 | instance Scripts.ValidatorTypes StakingType where 32 | type instance DatumType StakingType = StakingDatum 33 | type instance RedeemerType StakingType = StakingRedeemer 34 | 35 | typedValidatorStaking :: Staking -> Scripts.TypedValidator StakingType 36 | typedValidatorStaking staking = Scripts.mkTypedValidator @StakingType 37 | ($$(PlutusTx.compile [|| mkValidatorStaking ||]) 38 | `PlutusTx.applyCode` PlutusTx.liftCode mainTokenAC 39 | `PlutusTx.applyCode` PlutusTx.liftCode staking) 40 | $$(PlutusTx.compile [|| wrap ||]) 41 | where 42 | wrap = Scripts.wrapValidator @StakingDatum @StakingRedeemer 43 | 44 | validatorStaking :: Staking -> Scripts.Validator 45 | validatorStaking = Scripts.validatorScript . typedValidatorStaking 46 | 47 | addressStaking :: Staking -> Ledger.Address 48 | addressStaking = scriptAddress . validatorStaking 49 | -------------------------------------------------------------------------------- /test/Tests/Tests.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Tests.Tests 3 | Description : A module to export all tests to the the main test file. 4 | Copyright : P2P Solutions Ltd. 5 | License : GPL-3 6 | Maintainer : laurynas@adafinance.io 7 | Stability : develop 8 | -} 9 | 10 | module Tests.Tests ( tests ) where 11 | 12 | -- Third-party libraries. 13 | import Test.Tasty 14 | 15 | -- Internal modules. 16 | import qualified Tests.BusinessTests 17 | import qualified Tests.OffChain.Claim 18 | import qualified Tests.OffChain.Compound 19 | import qualified Tests.OffChain.Deposit 20 | import qualified Tests.OffChain.Feed 21 | import qualified Tests.OffChain.Register 22 | import qualified Tests.OffChain.Start 23 | import qualified Tests.OffChain.Unregister 24 | import qualified Tests.OffChain.Withdraw 25 | --import qualified Tests.OffChain.UseCaseTests 26 | import qualified Tests.OnChain.Claim 27 | import qualified Tests.OnChain.Compound 28 | import qualified Tests.OnChain.Deposit 29 | import qualified Tests.OnChain.Feed 30 | import qualified Tests.OnChain.Withdraw 31 | 32 | tests :: TestTree 33 | tests = testGroup "all" 34 | [ Tests.BusinessTests.tests 35 | , Tests.OffChain.Claim.tests 36 | , Tests.OffChain.Compound.tests 37 | , Tests.OffChain.Deposit.tests 38 | , Tests.OffChain.Feed.tests 39 | , Tests.OffChain.Register.tests 40 | , Tests.OffChain.Start.tests 41 | , Tests.OffChain.Unregister.tests 42 | , Tests.OffChain.Withdraw.tests 43 | -- , Tests.OffChain.UseCaseTests.tests 44 | , Tests.OnChain.Claim.tests 45 | , Tests.OnChain.Compound.tests 46 | , Tests.OnChain.Deposit.tests 47 | , Tests.OnChain.Feed.tests 48 | , Tests.OnChain.Withdraw.tests 49 | ] 50 | -------------------------------------------------------------------------------- /test/Tests/OnChain/Feed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OnChain.Feed 12 | Description : A test to simulate an attach on the on-chain code of feed. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OnChain.Feed where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Plutus.Trace.Emulator as Emulator 26 | import Plutus.V1.Ledger.Scripts 27 | import Test.Tasty 28 | 29 | -- Internal modules. 30 | import MainToken 31 | import Staking 32 | 33 | import Tests.Attacks.Feed 34 | import Tests.TestUtils 35 | 36 | tests :: TestTree 37 | tests = testGroup "onChainFeedTests" 38 | [ buildTest 39 | "feedAttackTest" 40 | feedAttackError 41 | feedAttackTrace 42 | ] 43 | 44 | feedAttackTrace :: EmulatorTrace () 45 | feedAttackTrace = do 46 | hAdminWallet <- activateContractWallet adminWallet $ runStaking 47 | (MicroToken 9_999_999) 48 | testStakingSettings 49 | void $ Emulator.waitNSlots 2 50 | staking <- getStaking hAdminWallet 51 | 52 | hAttack <- activateContractWallet adminWallet $ attackStakingEndpoints staking 53 | 54 | callEndpoint @"feedNegativeAttack" hAttack (MicroToken 2_222_222) 55 | void $ Emulator.waitNSlots 1 56 | 57 | feedAttackError :: [ScriptError] 58 | feedAttackError = pure $ 59 | EvaluationError 60 | [ "checkPoolFeed: Output value is wrong." 61 | , "PT5" 62 | ] 63 | "CekEvaluationFailure" 64 | -------------------------------------------------------------------------------- /test/Tests/OnChain/Claim.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OnChain.Claim 12 | Description : A test to simulate an attach on the on-chain code of claim. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OnChain.Claim where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Plutus.Trace.Emulator as Emulator 26 | import Plutus.V1.Ledger.Scripts 27 | import Test.Tasty 28 | 29 | -- Internal modules. 30 | import MainToken 31 | import Staking 32 | 33 | import Tests.Attacks.Claim 34 | import Tests.TestUtils 35 | 36 | tests :: TestTree 37 | tests = testGroup "onChainClaimTests" 38 | [ buildTest 39 | "claimAttackTest" 40 | claimAttackError 41 | claimAttackTrace 42 | ] 43 | 44 | claimAttackTrace :: EmulatorTrace () 45 | claimAttackTrace = do 46 | hAdminWallet <- activateContractWallet adminWallet $ runStaking 47 | (MicroToken 9_999_999) 48 | testStakingSettings 49 | pool <- getStaking hAdminWallet 50 | void $ Emulator.waitNSlots 2 51 | 52 | hUser <- activateContractWallet user1Wallet $ userEndpoints pool 53 | hAttack <- activateContractWallet user1Wallet $ attackUserEndpoints pool 54 | 55 | void $ waitNSlots 2 56 | 57 | callEndpoint @"register" hUser () 58 | void $ waitNSlots 2 59 | 60 | callEndpoint @"deposit" hUser (MicroToken 33_333_333) 61 | void $ waitNSlots 100 62 | 63 | callEndpoint @"claimAttack" hAttack () 64 | void $ Emulator.waitNSlots 2 65 | 66 | claimAttackError :: [ScriptError] 67 | claimAttackError = pure $ 68 | EvaluationError 69 | [ "checkPoolClaim: Pool ouput UTxO value is wrong." 70 | , "PT5" 71 | ] 72 | "CekEvaluationFailure" 73 | -------------------------------------------------------------------------------- /test/Tests/OffChain/UseCaseTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | module Tests.OffChain.UseCaseTests where 10 | 11 | -- GHC libraries. 12 | import Control.Lens 13 | import Control.Monad 14 | import Ledger.Value as Value 15 | import Plutus.Trace.Emulator as Emulator 16 | 17 | -- Third-praty libraries. 18 | import Plutus.Contract.Test 19 | import Test.Tasty 20 | import Plutus.V1.Ledger.Api (fromData, Data) 21 | 22 | -- Internal modules. 23 | import BCExplorer as BC ( printBlockChainCFD 24 | , FromDataFunc (..) 25 | ) 26 | import MainToken 27 | import Staking.Business 28 | import Staking.OffChain 29 | import Staking.Validator 30 | import Staking.Types 31 | 32 | import Tests.TestUtils 33 | 34 | tests :: TestTree 35 | tests = testGroup "useCaseTests" 36 | [ useCaseTest0 37 | , useCaseTest1 38 | , useCaseTest2 39 | ] 40 | 41 | -- Claim nothing due to not reaching the minimum amount 42 | useCaseTest0 :: TestTree 43 | useCaseTest0 = checkPredicateOptions 44 | (defaultCheckOptions & emulatorConfig .~ emCfg) 45 | "Test 0" 46 | ( walletFundsChange adminWallet (mainTokenValue (-7_777_777)) 47 | .&&. walletFundsChange user1Wallet (mainTokenValue (-100_000_000)) 48 | .&&. walletFundsChange testRefWallet (mainTokenValue refDepositFees) 49 | .&&. walletFundsChange testDaoWallet (mainTokenValue daoDepositFees) 50 | .&&. walletFundsChange testAffWallet (mainTokenValue affDepositFees) 51 | .&&. valueAtAddress (addressStaking testStaking) scriptValueOK 52 | ) 53 | useCaseTrace0 54 | where 55 | totalDepositFees = refDepositFees + daoDepositFees + affDepositFees 56 | 57 | feesDepositDistribution = depositFees 100_000_000 testOperationSettings 58 | 59 | refDepositFees, daoDepositFees, affDepositFees :: Integer 60 | refDepositFees = refillFees feesDepositDistribution 61 | daoDepositFees = daoFees feesDepositDistribution 62 | affDepositFees = affFees feesDepositDistribution 63 | 64 | scriptValueOK :: Value -> Bool 65 | scriptValueOK val = val == userScript <> stakingScript 66 | -------------------------------------------------------------------------------- /test/Tests/OffChain/Start.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | {-| 10 | Module : Tests.OffChain.Start 11 | Description : A test to check the behavior of the start operation. 12 | Copyright : P2P Solutions Ltd. 13 | License : GPL-3 14 | Maintainer : laurynas@adafinance.io 15 | Stability : develop 16 | -} 17 | 18 | module Tests.OffChain.Start where 19 | 20 | -- GHC libraries. 21 | import Control.Monad 22 | 23 | -- Third-praty libraries. 24 | import Control.Lens 25 | import Ledger 26 | import Plutus.Contract.Test 27 | import Plutus.V1.Ledger.Api (fromData, Data) 28 | import Plutus.Trace.Emulator as Emulator 29 | import Test.Tasty 30 | 31 | -- Internal modules. 32 | import BCExplorer as BC (printBlockChainCFD, FromDataFunc (..)) 33 | import MainToken 34 | import Staking.OffChain 35 | import Staking.Validator 36 | import Staking.Types 37 | 38 | import Tests.TestUtils 39 | 40 | tests :: TestTree 41 | tests = testGroup "offChainStartTests" 42 | [ startTest ] 43 | 44 | {-| Trace Summary: 45 | A staking pool is created with an initial amount of microtokens. 46 | 47 | Trace Description: 48 | * adminWallet starts the staking pool with initialFounds microtokens. 49 | * wait 10 slots 50 | -} 51 | 52 | -- The initial amount of microtokens on the staking pool. 53 | initialFounds :: Integer 54 | initialFounds = 7_777_777 55 | 56 | startTrace :: EmulatorTrace () 57 | startTrace = do 58 | void $ activateContractWallet adminWallet $ runStaking 59 | (MicroToken initialFounds) 60 | testStakingSettings 61 | void $ waitNSlots 10 62 | 63 | BC.printBlockChainCFD [BC.FD (fromData :: Data -> Maybe StakingDatum)] 64 | 65 | 66 | {- Test Summary: 67 | Test a standard usage of the start operation to initialize a staking pool. 68 | 69 | In this test we check that: 70 | * adminWallet has initialFounds less microtokens. 71 | * The staking script has the NFT plus initialFounds microtokens. 72 | -} 73 | startTest :: TestTree 74 | startTest = checkPredicateOptions 75 | (defaultCheckOptions & emulatorConfig .~ emCfg) 76 | "startTest" 77 | ( walletFundsChange adminWallet (mainTokenValue (-initialFounds) 78 | <> minAda (-1)) 79 | .&&. valueAtAddress (addressStaking testStaking) scriptValueOK 80 | ) 81 | startTrace 82 | where 83 | stakingScript :: Value 84 | stakingScript = testStakingNFT <> mainTokenValue initialFounds <> minAda 1 85 | 86 | scriptValueOK :: Value -> Bool 87 | scriptValueOK val = val == stakingScript 88 | -------------------------------------------------------------------------------- /src/Utils/OffChain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | {-| 7 | Module : Utils.OffChain 8 | Description : Common off-chain functions. 9 | Copyright : P2P Solutions Ltd. 10 | License : GPL-3 11 | Maintainer : laurynas@adafinance.io 12 | Stability : develop 13 | -} 14 | 15 | module Utils.OffChain where 16 | 17 | import qualified Data.Text as T 18 | import qualified Data.Map as Map 19 | import Control.Lens 20 | 21 | import qualified PlutusTx 22 | import Ledger hiding (singleton) 23 | import Ledger.Value (assetClassValueOf) 24 | import Plutus.Contract as Contract 25 | import Plutus.Contracts.Currency as Currency 26 | 27 | {- | Get the datum from a ChainIndexTxOut, only if it is not a datum hash. -} 28 | getChainIndexTxOutDatum :: PlutusTx.FromData d => ChainIndexTxOut -> Maybe d 29 | getChainIndexTxOutDatum ciTxOut = 30 | case matching _ScriptChainIndexTxOut ciTxOut of 31 | Right (_, _, Right d, _) -> PlutusTx.fromBuiltinData $ getDatum d 32 | _ -> Nothing 33 | 34 | {- | Get the value from a ChainIndexTxOut. -} 35 | getChainIndexTxOutValue :: ChainIndexTxOut -> Value 36 | getChainIndexTxOutValue o = o ^. ciTxOutValue 37 | 38 | {- | Off-chain function for getting the unique UTxO for the given address that 39 | contains the given NFT. The ChainIndexTxOut value, if possible, has 40 | the datum field loaded with the correct datum result of calling 41 | `datumFromHash`. 42 | -} 43 | lookupScriptUTxO 44 | :: forall w s 45 | . Address 46 | -> AssetClass 47 | -> Contract w s T.Text (TxOutRef, ChainIndexTxOut) 48 | lookupScriptUTxO addr nftAC = do 49 | utxos <- Map.filter (checkTxHasNFT nftAC . (^. ciTxOutValue)) <$> utxosAt addr 50 | case Map.toList utxos of 51 | [(oref, o)] -> (oref,) <$> ciTxOutDatum loadDatum o 52 | _ -> throwError $ T.unwords 53 | [ "Can't find the unique utxo of address" 54 | , T.pack $ show addr 55 | , "with the nft" 56 | , T.pack $ show nftAC 57 | ] 58 | where 59 | loadDatum 60 | :: Either DatumHash Datum 61 | -> Contract w s T.Text (Either DatumHash Datum) 62 | loadDatum lhd@(Left dh) = maybe lhd Right <$> datumFromHash dh 63 | loadDatum d = return d 64 | 65 | checkTxHasNFT :: AssetClass -> Value -> Bool 66 | checkTxHasNFT asc v = assetClassValueOf v asc == 1 67 | 68 | -- | Utility for forging an NFT. 69 | forgeNFT :: PubKeyHash -> TokenName -> Contract w s T.Text OneShotCurrency 70 | forgeNFT pkh tkn = mapError (T.pack . show @Currency.CurrencyError) $ 71 | mintContract pkh [(tkn, 1)] 72 | -------------------------------------------------------------------------------- /test/Tests/Attacks/Feed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | {-| 7 | Module : Tests.Attacks.Feed 8 | Description : A new off-chain code to test an attack the feed on-chain validator. 9 | Copyright : P2P Solutions Ltd. 10 | License : GPL-3 11 | Maintainer : laurynas@adafinance.io 12 | Stability : develop 13 | -} 14 | 15 | module Tests.Attacks.Feed 16 | ( AttackSchema 17 | -- ^ Endpoints 18 | , attackStakingEndpoints 19 | ) where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | import Data.Monoid (Last (..)) 24 | import Data.Text as T (Text) 25 | 26 | -- Third-party libraries libraries. 27 | import Ledger hiding (singleton) 28 | import Ledger.Constraints as Constraints 29 | import Plutus.Contract as Contract 30 | import PlutusTx 31 | 32 | -- Internal modules. 33 | import MainToken 34 | import Staking.Types 35 | import Utils.OffChain 36 | import Tests.Attacks.AttackUtils 37 | import Tests.TestUtils 38 | 39 | -- Schema. 40 | type AttackSchema = Endpoint "feedNegativeAttack" MainToken 41 | 42 | attackStakingEndpoints :: Staking -> Contract (Last Staking) AttackSchema Text () 43 | attackStakingEndpoints staking = forever 44 | $ handleError logError 45 | $ awaitPromise feedNegativeEndpoint 46 | where 47 | feedNegativeEndpoint :: Promise (Last Staking) AttackSchema Text () 48 | feedNegativeEndpoint = endpoint @"feedNegativeAttack" $ 49 | feedNegativeAttack staking 50 | 51 | feedNegativeAttack :: Staking -> MainToken -> Contract w s Text () 52 | feedNegativeAttack staking am = do 53 | (orefStaking, oStaking) <- findStaking staking 54 | ownPKH <- Contract.ownPubKeyHash 55 | stakingDat <- getContractDatum oStaking 56 | 57 | let newDat = stakingDat 58 | oldVal = getChainIndexTxOutValue oStaking 59 | negativeAm = mainTokenValue (-(getMicroToken am)) 60 | positiveAm = mainTokenValue (getMicroToken am) 61 | newVal = oldVal <> negativeAm 62 | 63 | red = Redeemer $ PlutusTx.toBuiltinData $ Feed am 64 | lookups = mkLookups staking [(orefStaking, oStaking)] 65 | tx = 66 | Constraints.mustSpendScriptOutput orefStaking red 67 | <> Constraints.mustPayToTheScript newDat newVal 68 | <> Constraints.mustPayToPubKey ownPKH (positiveAm <> minAda 1) 69 | 70 | submittedTx <- submitTxConstraintsWith lookups tx 71 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 72 | logInfo @String $ "Staking fed with " ++ show am ++ 73 | " micro MyToken tokens." 74 | -------------------------------------------------------------------------------- /test/Tests/OffChain/Feed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OffChain.Feed 12 | Description : A test to check the behavior of the feed operation. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OffChain.Feed where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Control.Lens 26 | import Ledger 27 | import Plutus.Contract.Test 28 | import Plutus.V1.Ledger.Api (fromData, Data) 29 | import Plutus.Trace.Emulator as Emulator 30 | import Test.Tasty 31 | 32 | -- Internal modules. 33 | import BCExplorer as BC (printBlockChainCFD, FromDataFunc (..)) 34 | import MainToken 35 | import Staking.OffChain 36 | import Staking.Validator 37 | import Staking.Types 38 | 39 | import Tests.TestUtils 40 | 41 | tests :: TestTree 42 | tests = testGroup "offChainFeedTests" 43 | [ feedTest ] 44 | 45 | {-| Trace Summary: 46 | A staking pool is created with an initial amount of microtokens, then the 47 | adminWallet feed the staking pool with some microtokens. 48 | 49 | Trace Description: 50 | * adminWallet starts the staking pool with initialFounds microtokens. 51 | * wait 2 slots 52 | * adminWallet feed the staking pool with feedValue microtokens. 53 | * wait 10 slots 54 | -} 55 | 56 | -- The initial amount of microtokens on the staking pool. 57 | initialFounds :: Integer 58 | initialFounds = 7_777_777 59 | 60 | -- The value to feed the staking pool 61 | feedValue :: Integer 62 | feedValue = 22_222_222 63 | 64 | feedTrace :: EmulatorTrace () 65 | feedTrace = do 66 | hAdminWallet <- activateContractWallet adminWallet $ 67 | runStaking (MicroToken initialFounds) testStakingSettings 68 | void $ waitNSlots 2 69 | 70 | callEndpoint @"feed" hAdminWallet (MicroToken feedValue) 71 | void $ waitNSlots 10 72 | 73 | BC.printBlockChainCFD [BC.FD (fromData :: Data -> Maybe StakingDatum)] 74 | 75 | 76 | {- Test Summary: 77 | Test a standard usage of the feed operation. 78 | 79 | In this test we check that: 80 | * adminWallet has initialFounds less microtokens. 81 | * The staking script has the NFT plus initialFounds + deedValue microtokens. 82 | -} 83 | feedTest :: TestTree 84 | feedTest = checkPredicateOptions 85 | (defaultCheckOptions & emulatorConfig .~ emCfg) 86 | "feedTest" 87 | ( walletFundsChange adminWallet 88 | (mainTokenValue (-initialFounds - feedValue) 89 | <> minAda (-1)) 90 | .&&. valueAtAddress (addressStaking testStaking) scriptValueOK 91 | ) 92 | feedTrace 93 | where 94 | stakingScript :: Value 95 | stakingScript = testStakingNFT <> mainTokenValue (initialFounds + feedValue) 96 | <> minAda 1 97 | 98 | scriptValueOK :: Value -> Bool 99 | scriptValueOK val = val == stakingScript 100 | -------------------------------------------------------------------------------- /test/Tests/OffChain/Register.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OffChain.Register 12 | Description : A test to check the behavior of the register operation. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OffChain.Register where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Control.Lens 26 | import Ledger 27 | import Plutus.Contract.Test 28 | import Plutus.V1.Ledger.Api (fromData, Data) 29 | import Plutus.Trace.Emulator as Emulator 30 | import Test.Tasty 31 | 32 | -- Internal modules. 33 | import BCExplorer as BC (printBlockChainCFD, FromDataFunc (..)) 34 | import MainToken 35 | import Staking.OffChain 36 | import Staking.Validator 37 | import Staking.Types 38 | 39 | import Tests.TestUtils 40 | 41 | tests :: TestTree 42 | tests = testGroup "offChainRegisterTests" 43 | [ registerTest ] 44 | 45 | {-| Trace Summary: 46 | A staking pool is created with an initial amount of microtokens and a user 47 | registers into the staking pool. 48 | 49 | Trace Description: 50 | * adminWallet starts the staking pool with initialFounds microtokens. 51 | * wait 2 slots 52 | * user1Wallet registers into the staking pool. 53 | * wait 10 slots 54 | -} 55 | 56 | -- The initial amount of microtokens on the staking pool. 57 | initialFounds :: Integer 58 | initialFounds = 7_777_777 59 | 60 | registerTrace :: EmulatorTrace () 61 | registerTrace = do 62 | hAdminWallet <- activateContractWallet adminWallet $ 63 | runStaking (MicroToken initialFounds) testStakingSettings 64 | pool <- getStaking hAdminWallet 65 | void $ waitNSlots 2 66 | 67 | hUser1 <- activateContractWallet user1Wallet $ userEndpoints pool 68 | void $ waitNSlots 2 69 | 70 | callEndpoint @"register" hUser1 () 71 | void $ waitNSlots 10 72 | 73 | BC.printBlockChainCFD [BC.FD (fromData :: Data -> Maybe StakingDatum)] 74 | 75 | 76 | {- Test Summary: 77 | Test a standard usage of the register operation. 78 | 79 | In this test we check that: 80 | * adminWallet has initialFounds less microtokens. 81 | * The staking script has the NFT plus initialFounds microtokens. 82 | -} 83 | registerTest :: TestTree 84 | registerTest = checkPredicateOptions 85 | (defaultCheckOptions & emulatorConfig .~ emCfg) 86 | "registerTest" 87 | ( walletFundsChange adminWallet (mainTokenValue (-initialFounds) 88 | <> minAda (-1)) 89 | .&&. valueAtAddress (addressStaking testStaking) scriptValueOK 90 | ) 91 | registerTrace 92 | where 93 | stakingScript :: Value 94 | stakingScript = testStakingNFT <> mainTokenValue initialFounds <> minAda 1 95 | 96 | userScript :: Value 97 | userScript = testUserNFT <> minAda 1 98 | 99 | scriptValueOK :: Value -> Bool 100 | scriptValueOK val = val == userScript <> stakingScript 101 | -------------------------------------------------------------------------------- /test/Tests/OnChain/Compound.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OnChain.Compound 12 | Description : A test to simulate an attach on the on-chain code of compound. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OnChain.Compound where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Plutus.Trace.Emulator as Emulator 26 | import Plutus.V1.Ledger.Scripts 27 | import Test.Tasty 28 | 29 | -- Internal modules. 30 | import MainToken 31 | import Staking 32 | 33 | import Tests.Attacks.Compound 34 | import Tests.TestUtils 35 | 36 | tests :: TestTree 37 | tests = testGroup "onChainCompoundTests" 38 | [ buildTest "compoundAttackTest" 39 | compoundAttackError 40 | compoundAttackTrace 41 | , buildTest "fakeCompoundAttackTest" 42 | fakeCompoundAttackError 43 | fakeCompoundAttackTrace 44 | ] 45 | 46 | compoundAttackTrace :: EmulatorTrace () 47 | compoundAttackTrace = do 48 | hAdminWallet <- activateContractWallet adminWallet $ runStaking 49 | (MicroToken 7_777_777) 50 | testStakingSettings 51 | pool <- getStaking hAdminWallet 52 | void $ waitNSlots 2 53 | 54 | hUser <- activateContractWallet user1Wallet $ userEndpoints pool 55 | hAttack <- activateContractWallet user1Wallet $ attackUserEndpoints pool 56 | 57 | void $ waitNSlots 2 58 | 59 | callEndpoint @"register" hUser () 60 | void $ waitNSlots 2 61 | 62 | callEndpoint @"deposit" hUser (MicroToken 33_333_333) 63 | void $ waitNSlots 100 64 | 65 | callEndpoint @"compoundAttack" hAttack () 66 | void $ waitNSlots 2 67 | 68 | compoundAttackError :: [ScriptError] 69 | compoundAttackError = 70 | [ EvaluationError 71 | [ "checkUserCompound: User output UTxO datum is wrong." 72 | , "PT5" 73 | ] 74 | "CekEvaluationFailure" 75 | , EvaluationError 76 | [ "checkPoolClaim: Pool ouput UTxO value is wrong." 77 | , "PT5" 78 | ] 79 | "CekEvaluationFailure" 80 | ] 81 | 82 | fakeCompoundAttackTrace :: EmulatorTrace () 83 | fakeCompoundAttackTrace = do 84 | hAdminWallet <- activateContractWallet adminWallet $ runStaking 85 | (MicroToken 7_777_777) 86 | testStakingSettings 87 | pool <- getStaking hAdminWallet 88 | void $ waitNSlots 2 89 | 90 | hUser <- activateContractWallet user1Wallet $ userEndpoints pool 91 | hAttack <- activateContractWallet user1Wallet $ attackUserEndpoints pool 92 | 93 | void $ waitNSlots 2 94 | 95 | callEndpoint @"register" hUser () 96 | void $ waitNSlots 2 97 | 98 | callEndpoint @"deposit" hUser (MicroToken 33_333_333) 99 | void $ waitNSlots 100 100 | 101 | callEndpoint @"fakeCompoundAttack" hAttack () 102 | void $ waitNSlots 2 103 | 104 | fakeCompoundAttackError :: [ScriptError] 105 | fakeCompoundAttackError = pure $ 106 | EvaluationError 107 | [ "checkUserCompound: User output UTxO datum is wrong." 108 | , "PT5" 109 | ] 110 | "CekEvaluationFailure" 111 | -------------------------------------------------------------------------------- /src/Staking/Business/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | 9 | {-| 10 | Module : Staking.Business.Types 11 | Description : The main types used to build the logic of business operations. 12 | Copyright : P2P Solutions Ltd. 13 | License : GPL-3 14 | Maintainer : laurynas@adafinance.io 15 | Stability : develop 16 | -} 17 | 18 | module Staking.Business.Types where 19 | 20 | import Data.Aeson (FromJSON, ToJSON) 21 | import GHC.Generics (Generic) 22 | import qualified Prelude as HP (Show (..), Eq (..)) 23 | 24 | import Ledger 25 | import qualified PlutusTx 26 | import PlutusTx.Prelude 27 | 28 | -- | The Pool State stores the information of active users in the staking pool. 29 | newtype PoolState = PoolState { activeUsers :: [(PubKeyHash, AssetClass)] } 30 | deriving (HP.Eq, HP.Show, Generic) 31 | deriving anyclass (FromJSON, ToJSON) 32 | 33 | instance Eq PoolState where 34 | {-# INLINABLE (==) #-} 35 | ps1 == ps2 = activeUsers ps1 == activeUsers ps2 36 | 37 | mkPoolState :: [(PubKeyHash, AssetClass)] -> PoolState 38 | mkPoolState aus = PoolState { activeUsers = aus } 39 | 40 | -- | The user state consists eith the following fields: 41 | -- user : pub key hash of the user 42 | -- deposits : the list of deposits 43 | -- lastClaim : the time of the last claim, if there is someone. 44 | data UserState = UserState 45 | { user :: !PubKeyHash 46 | , deposits :: ![Deposit] 47 | , lastClaim :: !(Maybe POSIXTime) 48 | } 49 | deriving (HP.Eq, HP.Show, Generic) 50 | deriving anyclass (FromJSON, ToJSON) 51 | 52 | instance Eq UserState where 53 | {-# INLINABLE (==) #-} 54 | us1 == us2 = deposits us1 == deposits us2 55 | && lastClaim us1 == lastClaim us2 56 | 57 | mkUserState 58 | :: PubKeyHash 59 | -> [Deposit] 60 | -> Maybe POSIXTime 61 | -> UserState 62 | mkUserState u d l = UserState { user = u, deposits = d, lastClaim = l } 63 | 64 | -- | Settings for the staking operations: 65 | -- depositFee : amount of fees paid in the deposit operation (per million) 66 | -- withdrawFee : amount of fees paid in the deposit operation (per million) 67 | -- daoShare : % of fees for DAO program (* 1 million) 68 | -- affShare : % of fees for affiliate network (* 1 million) 69 | -- minDeposit : Minimum valid deposit in micro token 70 | -- minWithdraw : Minimum valid withdraw in micro token 71 | data OperationSettings = OperationSettings { depositFee :: !Integer 72 | , withdrawFee :: !Integer 73 | , daoShare :: !Integer 74 | , affShare :: !Integer 75 | , minDeposit :: !Integer 76 | , minWithdraw :: !Integer 77 | , minClaim :: !Integer 78 | } 79 | deriving (HP.Eq, HP.Show, Generic) 80 | deriving anyclass (FromJSON, ToJSON) 81 | 82 | -- | Representation of fees to be paid by deposit and withdraw operations. 83 | data FeesDistribution = FeesDistribution { refillFees :: !Integer 84 | , daoFees :: !Integer 85 | , affFees :: !Integer 86 | } 87 | deriving (HP.Eq, HP.Show, Generic) 88 | deriving anyclass (FromJSON, ToJSON) 89 | 90 | -- | A deposit consists on the time the deposit was performed and the amount. 91 | type Deposit = (POSIXTime, Integer) 92 | 93 | timeDeposit :: Deposit -> POSIXTime 94 | timeDeposit = fst 95 | 96 | amountDeposit :: Deposit -> Integer 97 | amountDeposit = snd 98 | 99 | PlutusTx.makeLift ''OperationSettings 100 | PlutusTx.unstableMakeIsData ''PoolState 101 | PlutusTx.unstableMakeIsData ''UserState 102 | -------------------------------------------------------------------------------- /test/Tests/Attacks/AttackUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | {-| 7 | Module : Tests.Attacks.AttackUtils 8 | Description : Helper functions to be used by the attacks. 9 | Copyright : P2P Solutions Ltd. 10 | License : GPL-3 11 | Maintainer : laurynas@adafinance.io 12 | Stability : develop 13 | -} 14 | 15 | module Tests.Attacks.AttackUtils where 16 | 17 | import Control.Monad 18 | import qualified Data.Map as Map 19 | import Data.Text as T (Text, pack) 20 | 21 | -- Third-party libraries libraries. 22 | import Ledger hiding (singleton) 23 | import Ledger.Constraints as Constraints 24 | import Ledger.Value as Value 25 | import Plutus.Contract as Contract 26 | 27 | -- Internal modules. 28 | import MainToken 29 | import Staking.Business 30 | import Staking.Types 31 | import Staking.Validator 32 | import Utils.OffChain 33 | 34 | -- Helper functions. 35 | mkLookups :: 36 | Staking 37 | -> [(TxOutRef, ChainIndexTxOut)] 38 | -> ScriptLookups StakingType 39 | mkLookups p utxos = 40 | Constraints.typedValidatorLookups (typedValidatorStaking p) 41 | <> Constraints.otherScript (validatorStaking p) 42 | <> Constraints.unspentOutputs (Map.fromList utxos) 43 | 44 | -- | Monadic function for getting the datum from a staking pool UTxO. 45 | getPoolState :: ChainIndexTxOut -> Contract w s T.Text PoolState 46 | getPoolState o = 47 | case getChainIndexTxOutDatum o of 48 | Just (PoolDatum ps) -> return ps 49 | Just (UserDatum _) -> 50 | throwError "Expected StakingDatum but found UserDatum." 51 | Nothing -> throwError "Cannot find contract datum." 52 | 53 | -- | Monadic function for getting the UserState from a user script UTxO. 54 | getUserState :: ChainIndexTxOut -> Contract w s T.Text UserState 55 | getUserState o = case getChainIndexTxOutDatum o of 56 | Just dat -> case dat of 57 | PoolDatum _ -> 58 | throwError "Expected UserDatum but found StakingDatum." 59 | UserDatum res -> return res 60 | Nothing -> throwError "Cannot find contract datum." 61 | 62 | {- | Monadic function returning the user script UTxO corresponding to the 63 | PubKeyHash. -} 64 | findUserUTxO 65 | :: Staking 66 | -> PubKeyHash 67 | -> Contract w s Text (TxOutRef, ChainIndexTxOut) 68 | findUserUTxO staking pkh = do 69 | (_, oStaking) <- findStaking staking 70 | dat <- getContractDatum oStaking 71 | case dat of 72 | UserDatum _ -> throwError 73 | "Expected StakingDatum but found UserDatum in staking script UTxO." 74 | PoolDatum ps -> 75 | case getUserNFT ps pkh of 76 | Just userNFT -> lookupScriptUTxO 77 | (addressStaking staking) 78 | userNFT 79 | _ -> throwError "Could not find user NFT." 80 | 81 | -- | Monadic function returning the UTxO corresponding to the staking pool. 82 | findStaking :: Staking -> Contract w s Text (TxOutRef, ChainIndexTxOut) 83 | findStaking staking@Staking{..} = lookupScriptUTxO (addressStaking staking) nft 84 | 85 | -- | Monadic function for getting the datum from a ChainIndexTxOut. 86 | getContractDatum :: ChainIndexTxOut -> Contract w s T.Text StakingDatum 87 | getContractDatum = 88 | maybe (throwError "Cannot find contract datum") return . 89 | getChainIndexTxOutDatum 90 | 91 | {- | Monadic function for checking if there is enough funds in pool UTxO for a 92 | claim or compound transaction -} 93 | checkMinFundsPoolUTxO :: Staking -> Integer -> Contract w s T.Text () 94 | checkMinFundsPoolUTxO staking rews = do 95 | (_, oStaking) <- findStaking staking 96 | when 97 | (assetClassValueOf (getChainIndexTxOutValue oStaking) mainTokenAC < rews) 98 | $ throwError $ pack $ "Claim or Compound transaction not issued due to " 99 | ++ "unsufficient funds in pool UTxO." 100 | -------------------------------------------------------------------------------- /staking-pool-sc.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: 2.4 2 | Name: CardanoStakingPool 3 | Version: 0.1.0.0 4 | Author: P2P Solutions Ltd. 5 | Maintainer: laurynas@adafinance.io 6 | Build-Type: Simple 7 | 8 | library 9 | hs-source-dirs: src 10 | exposed-modules: MainToken 11 | , Utils.OffChain 12 | , Utils.ScriptContext 13 | , Staking 14 | , Staking.Types 15 | , Staking.OnChain 16 | , Staking.OffChain 17 | , Staking.Validator 18 | , Staking.Tokens 19 | , Staking.Business 20 | , Staking.Business.User 21 | , Staking.Business.Pool 22 | , Staking.Business.Types 23 | build-depends: aeson 24 | , base ^>= 4.14.1.0 25 | , containers 26 | , data-default 27 | , freer-extras 28 | , playground-common 29 | , plutus-contract 30 | , plutus-ledger 31 | , plutus-ledger-api 32 | , plutus-tx-plugin 33 | , plutus-tx 34 | , plutus-use-cases 35 | , prettyprinter 36 | , text 37 | , lens 38 | default-language: Haskell2010 39 | ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas 40 | -fno-omit-interface-pragmas -fno-strictness 41 | -fno-spec-constr -fno-specialise -fno-warn-orphans 42 | 43 | test-suite test 44 | type: exitcode-stdio-1.0 45 | hs-source-dirs: test 46 | main-is: Main.hs 47 | other-modules: BCExplorer 48 | , Tests.BusinessTests 49 | , Tests.TestUtils 50 | , Tests.Tests 51 | , Tests.Attacks.AttackUtils 52 | , Tests.Attacks.Claim 53 | , Tests.Attacks.Compound 54 | , Tests.Attacks.Deposit 55 | , Tests.Attacks.Feed 56 | , Tests.Attacks.Withdraw 57 | , Tests.OnChain.Claim 58 | , Tests.OnChain.Compound 59 | , Tests.OnChain.Deposit 60 | , Tests.OnChain.Feed 61 | , Tests.OnChain.Withdraw 62 | , Tests.OffChain.Claim 63 | , Tests.OffChain.Compound 64 | , Tests.OffChain.Deposit 65 | , Tests.OffChain.Feed 66 | , Tests.OffChain.Register 67 | , Tests.OffChain.Start 68 | , Tests.OffChain.Unregister 69 | , Tests.OffChain.Withdraw 70 | -- , Tests.OffChain.UseCaseTests 71 | 72 | default-language: Haskell2010 73 | ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas 74 | -fno-omit-interface-pragmas -fno-strictness 75 | -fno-spec-constr -fno-specialise 76 | build-depends: base ^>=4.14.1.0 77 | , aeson 78 | , ansi-terminal 79 | , containers 80 | , data-default 81 | , freer-extras 82 | , playground-common 83 | , plutus-pab 84 | , plutus-contract 85 | , plutus-ledger 86 | , plutus-ledger-api 87 | , plutus-tx-plugin 88 | , plutus-tx 89 | , plutus-use-cases 90 | , prettyprinter 91 | , text 92 | , freer-simple 93 | , lens <= 4.19.2 94 | , plutus-core 95 | , bytestring 96 | , tasty 97 | , tasty-hunit 98 | , QuickCheck 99 | , tasty-quickcheck 100 | , text 101 | , prettyprinter 102 | , strict-containers 103 | , P2PStakingPool 104 | , foldl 105 | -------------------------------------------------------------------------------- /test/Tests/Attacks/Claim.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | {-| 8 | Module : Tests.Attacks.Claim 9 | Description : A new off-chain code to test an attack the claim validator. 10 | Copyright : P2P Solutions Ltd. 11 | License : GPL-3 12 | Maintainer : laurynas@adafinance.io 13 | Stability : develop 14 | -} 15 | 16 | module Tests.Attacks.Claim 17 | ( AttackSchema 18 | -- ^ Endpoints 19 | , attackUserEndpoints 20 | ) where 21 | 22 | import Control.Monad 23 | import Data.Monoid (Last (..)) 24 | import Data.Text as T (Text) 25 | 26 | -- Third-party libraries libraries. 27 | import Ledger hiding (singleton) 28 | import Ledger.Constraints as Constraints 29 | import Plutus.Contract as Contract 30 | import PlutusTx 31 | 32 | -- Internal modules. 33 | import MainToken 34 | import Staking.Business 35 | import Staking.Types 36 | import Utils.OffChain 37 | import Tests.Attacks.AttackUtils 38 | import Tests.TestUtils 39 | 40 | -- Schema. 41 | type AttackSchema = 42 | Endpoint "claimAttack" () -- Claim and steal more than excepted 43 | 44 | attackUserEndpoints :: Staking -> Contract (Last Staking) AttackSchema Text () 45 | attackUserEndpoints staking = forever $ handleError logError $ awaitPromise 46 | claimAttackEndpoint 47 | where 48 | claimAttackEndpoint :: Promise (Last Staking) AttackSchema Text () 49 | claimAttackEndpoint = 50 | endpoint @"claimAttack" $ const $ claimAttack staking 51 | 52 | {-| Attack Summary: 53 | This attack attempts to claim twice the deserved reward for a claim 54 | operation. 55 | 56 | Modifications from the original OffChain code: 57 | * The newStakingValue consists of the old subtracted by twice the rewards 58 | of the claim operation. 59 | * Pay to the user's wallet twice the rewards of the claim operation. 60 | -} 61 | 62 | claimAttack :: forall w s. Staking -> Contract w s Text () 63 | claimAttack staking@Staking{..} = do 64 | cTime <- currentTime 65 | ownPKH <- Contract.ownPubKeyHash 66 | (orefStaking, oStaking) <- findStaking staking 67 | activeUsers <- getPoolState oStaking 68 | (orefUser, oUser) <- findUserUTxO staking ownPKH 69 | oldUserState <- getUserState oUser 70 | 71 | let claimRes = claim oldUserState cTime (opSettings settings) 72 | 73 | case claimRes of 74 | Nothing -> logInfo @String $ 75 | "Claimable rewards do not yet reach the minimum ammount." 76 | Just (newUserState, rews) -> do 77 | void $ checkMinFundsPoolUTxO staking rews 78 | let oldStakingVal = getChainIndexTxOutValue oStaking 79 | newStakingVal = oldStakingVal <> mainTokenValue (-2*rews) 80 | newStakingDat = PoolDatum activeUsers 81 | newUserDatum = UserDatum newUserState 82 | newUserVal = getChainIndexTxOutValue oUser 83 | 84 | range = interval cTime (cTime + validTimeRange) 85 | red = Redeemer $ PlutusTx.toBuiltinData $ 86 | Claim (MicroToken { getMicroToken = rews }) cTime 87 | lookups = mkLookups staking [ (orefStaking, oStaking) 88 | , (orefUser, oUser) ] 89 | tx = Constraints.mustSpendScriptOutput orefStaking red 90 | <> Constraints.mustSpendScriptOutput orefUser red 91 | <> Constraints.mustPayToTheScript newStakingDat newStakingVal 92 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 93 | <> Constraints.mustValidateIn range 94 | <> Constraints.mustPayToPubKey 95 | ownPKH (mainTokenValue (2*rews) <> minAda 1) 96 | 97 | logInfo @String $ 98 | "Trying to claim rewards of (" ++ show (2*rews) ++ 99 | " micro tokens)." 100 | submittedTx <- submitTxConstraintsWith lookups tx 101 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 102 | -------------------------------------------------------------------------------- /test/Tests/OnChain/Deposit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OnChain.Deposit 12 | Description : A test to simulate an attach on the on-chain code of deposit. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OnChain.Deposit where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Plutus.Trace.Emulator as Emulator 26 | import Plutus.V1.Ledger.Scripts 27 | import Test.Tasty 28 | 29 | -- Internal modules. 30 | import MainToken 31 | import Staking 32 | 33 | import Tests.Attacks.Deposit 34 | import Tests.TestUtils 35 | 36 | tests :: TestTree 37 | tests = testGroup "onChainDepositTests" 38 | [ buildTest 39 | "depositNegativeAttackTest" 40 | depositAttackError 41 | depositAttackTrace 42 | , buildTest 43 | "depositEmptyListAttackTest" 44 | depositEmptyListAttackError 45 | depositEmptyListAttackTrace 46 | , buildTest 47 | "depositWithoutFeesAttackTest" 48 | depositWithoutFeesAttackError 49 | depositWithoutFeesAttackTrace 50 | ] 51 | 52 | depositAttackTrace :: EmulatorTrace () 53 | depositAttackTrace = do 54 | hAdminWallet <- activateContractWallet adminWallet $ runStaking 55 | (MicroToken 9_999_999) 56 | testStakingSettings 57 | pool <- getStaking hAdminWallet 58 | void $ Emulator.waitNSlots 2 59 | 60 | hRegister <- activateContractWallet user1Wallet $ userEndpoints pool 61 | hAttack <- activateContractWallet user1Wallet $ attackUserEndpoints pool 62 | 63 | void $ waitNSlots 2 64 | 65 | callEndpoint @"register" hRegister () 66 | void $ waitNSlots 2 67 | 68 | -- This amount will be negative inside the endpoint 69 | callEndpoint @"depositNegativeAttack" hAttack (MicroToken 2_222_222) 70 | void $ Emulator.waitNSlots 10 71 | 72 | 73 | depositAttackError :: [ScriptError] 74 | depositAttackError = pure $ 75 | EvaluationError 76 | [ "checkUserDeposit: Amount to deposit does not reach minimum." 77 | , "PT5" 78 | ] 79 | "CekEvaluationFailure" 80 | 81 | depositEmptyListAttackTrace :: EmulatorTrace () 82 | depositEmptyListAttackTrace = do 83 | hAdminWallet <- activateContractWallet adminWallet $ runStaking 84 | (MicroToken 9_999_999) 85 | testStakingSettings 86 | pool <- getStaking hAdminWallet 87 | void $ Emulator.waitNSlots 2 88 | 89 | hRegister <- activateContractWallet user1Wallet $ userEndpoints pool 90 | hAttack <- activateContractWallet user1Wallet $ attackUserEndpoints pool 91 | 92 | void $ waitNSlots 2 93 | 94 | callEndpoint @"register" hRegister () 95 | void $ waitNSlots 2 96 | 97 | -- This amount won't be important because we want an empty list 98 | callEndpoint @"depositEmptyListAttack" hAttack (MicroToken 2_222_222) 99 | void $ Emulator.waitNSlots 10 100 | 101 | depositEmptyListAttackError :: [ScriptError] 102 | depositEmptyListAttackError = pure $ 103 | EvaluationError 104 | [ "checkUserDeposit: Datum is wrong." 105 | , "PT5" 106 | ] 107 | "CekEvaluationFailure" 108 | 109 | depositWithoutFeesAttackTrace :: EmulatorTrace () 110 | depositWithoutFeesAttackTrace = do 111 | hAdminWallet <- activateContractWallet adminWallet $ runStaking 112 | (MicroToken 9_999_999) 113 | testStakingSettings 114 | pool <- getStaking hAdminWallet 115 | void $ Emulator.waitNSlots 2 116 | 117 | hRegister <- activateContractWallet user1Wallet $ userEndpoints pool 118 | hAttack <- activateContractWallet user1Wallet $ attackUserEndpoints pool 119 | 120 | void $ waitNSlots 2 121 | 122 | callEndpoint @"register" hRegister () 123 | void $ waitNSlots 2 124 | 125 | callEndpoint @"depositWithoutFeesAttack" hAttack (MicroToken 2_222_222) 126 | void $ Emulator.waitNSlots 10 127 | 128 | depositWithoutFeesAttackError :: [ScriptError] 129 | depositWithoutFeesAttackError = pure $ 130 | EvaluationError 131 | [ "checkUserDeposit: Output value is wrong." 132 | , "PT5" 133 | ] 134 | "CekEvaluationFailure" 135 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # staking-pool-sc 2 | 3 | ## Introduction 4 | 5 | This staking pool contract allows users to stake *MyToken* tokens and claim rewards 6 | as time goes by. The pool has two APR levels depending on the duration of the deposits. 7 | Users get paid a level 1 APR of 15% for deposits with a duration of less 8 | than 90 days, and a level 2 APR of 20% for older deposits. 9 | 10 | Pools can be launched with an initial supply of rewards. Users can then register to the 11 | pool and make deposits and withdraws. These operations pay fees in *MyToken* that can 12 | be configured in the inital settings of the pool. The fees are distributed among three 13 | wallets, also configurable, that can serve different purposes to the pool operator. 14 | 15 | After some time, users can claim their rewards and retrieve them, or compound them to 16 | automatically stake back the rewards. 17 | 18 | ### Modules Design 19 | 20 | The staking pool contract includes: 21 | * Haskell off-chain code providing functions for each staking action. 22 | * Haskell on-chain code for validating each transaction. 23 | * Business logic code with abstract data types for the contract state 24 | and functions to operate with them. 25 | * Traces running on the EmulatorTrace for testing off-chain code, and test cases 26 | for each one of these traces. 27 | * Malicious off-chain code and traces running on the EmulatorTrace for testing 28 | the on-chain code, and test cases for each one of these traces. 29 | 30 | ## How to build 31 | 32 | Here you can find information about how to build this project and run the on-chain 33 | and off-chain tests. 34 | 35 | #### Plutus dependencies 36 | 37 | Install the development environment following the official [documentation](https://github.com/input-output-hk/plutus/tree/36e2c8bdbb6e70d25a31331e5cd23f26dc3162d5#how-to-build-the-projects-artifacts). 38 | Once you have all installed, you will start the environment with `nix-shell` 39 | from the plutus repository folder and change into the project folder. 40 | 41 | #### Compile 42 | 43 | ``` 44 | $> cabal build 45 | ``` 46 | 47 | #### Run tests 48 | 49 | ``` 50 | $> cabal run tests 51 | ``` 52 | 53 | #### More 54 | 55 | You also can load the library or the tests with the repl with `cabal repl` or 56 | `cabal repl test`. 57 | 58 | ## Supported Actions 59 | 60 | ### Admin actions 61 | 62 | #### Start 63 | 64 | Initializes the smart contract and creates the main staking pool UTxO with an 65 | initial supply of *MyToken* rewards tokens. 66 | 67 | #### Feed 68 | 69 | Given an amount of *MyToken* tokens, adds them to the rewards pool. 70 | 71 | ### User actions 72 | 73 | #### Register 74 | 75 | Registers the user into the staking pool, creating a pool user UTxO with no deposits in it. 76 | The public key hash of the user is stored in the main staking pool UTxO. 77 | 78 | #### Unregister 79 | 80 | Unregisters the user from the staking pool. The pool user UTxO is removed. 81 | 82 | #### Deposit 83 | 84 | Given an amount of *MyToken* tokens, makes a new deposit to the user current staking. 85 | All deposits are stored with a timestamp to be able to keep their duration and APR level. 86 | 87 | #### Withdraw 88 | 89 | Given an amount of *MyToken* tokens, withdraws that from the user current staking. 90 | Withdraws are always applied to the most recent deposits so older deposits can keep their APR levels. 91 | 92 | #### Claim 93 | 94 | The user claims all the earned rewards from the last claim until now. 95 | 96 | #### Compound 97 | 98 | The user claims all the earned rewards and automatically stakes them back instead of 99 | collecting them. 100 | 101 | 102 | ## Relevant Issues 103 | 104 | 1. This contract is implemented and tested using the Plutus simulated blockchain. 105 | It must still be adapted to work with the recently published PAB and a testnet. 106 | 107 | 2. The claim and compound operations are subject to congestion as they must both consume 108 | the main pool UTxO. Only one user per block can perform one of these operations. 109 | Fortunately, the pool UTxO is only consumed to access rewards, so the congestion can 110 | be solved by producing several UTxOs with rewards. 111 | 112 | 3. When a user registers, an NFT is minted to identify his pool user UTxO. 113 | When they unregister the NFT is not burned but paid to the user wallet. 114 | The NFT should be burned or, even better, subscription tokens could be used 115 | instead of NFTs. These are not burned on unregistration but paid back to the 116 | main pool UTxO to be used for future registrations. 117 | 118 | 4. The APR levels are currently not configurable at pool launch in the contract settings. 119 | They are instead hardcoded into the business logic, so the code should be edited and 120 | recompiled to modify them. Fortunately, the code is modularized so only a couple of lines 121 | must be changed. The APR configuration could be moved to the settings, at the cost of a more 122 | expensive and complex on-chain validation. 123 | -------------------------------------------------------------------------------- /test/Tests/OnChain/Withdraw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OnChain.Withdraw 12 | Description : A test to simulate an attach on the on-chain code of withdraw. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OnChain.Withdraw where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Plutus.Trace.Emulator as Emulator 26 | import Plutus.V1.Ledger.Scripts 27 | import Test.Tasty 28 | 29 | -- Internal modules. 30 | import MainToken 31 | import Staking 32 | 33 | import Tests.Attacks.Withdraw 34 | import Tests.TestUtils 35 | 36 | tests :: TestTree 37 | tests = testGroup "onChainWithdrawTests" 38 | [ buildTest 39 | "withdrawAttackTest" 40 | withdrawAttackError 41 | withdrawAttackTrace 42 | , buildTest 43 | "fakeWithdrawAttackTest" 44 | fakeWithdrawAttackError 45 | fakeWithdrawAttackTrace 46 | , buildTest 47 | "withdrawWithoutFeesAttackTest" 48 | withdrawWithoutFeesAttackError 49 | withdrawWithoutFeesAttackTrace 50 | ] 51 | 52 | withdrawAttackTrace :: EmulatorTrace () 53 | withdrawAttackTrace = do 54 | hAdminWallet <- activateContractWallet adminWallet $ runStaking 55 | (MicroToken 9_999_999) 56 | testStakingSettings 57 | pool <- getStaking hAdminWallet 58 | void $ Emulator.waitNSlots 2 59 | 60 | hUser <- activateContractWallet user1Wallet $ userEndpoints pool 61 | hAttack <- activateContractWallet user1Wallet $ attackUserEndpoints pool 62 | 63 | void $ waitNSlots 2 64 | 65 | callEndpoint @"register" hUser () 66 | void $ waitNSlots 2 67 | 68 | callEndpoint @"deposit" hUser (MicroToken 33_333_333) 69 | void $ waitNSlots 2 70 | 71 | -- We expect that this just half of this value will be withdrawn 72 | callEndpoint @"withdrawAttack" hAttack (MicroToken 2_222_222) 73 | void $ Emulator.waitNSlots 10 74 | 75 | withdrawAttackError :: [ScriptError] 76 | withdrawAttackError = pure $ 77 | EvaluationError 78 | [ "checkUserWithdraw: Output value is wrong." 79 | , "PT5" 80 | ] 81 | "CekEvaluationFailure" 82 | 83 | fakeWithdrawAttackTrace :: EmulatorTrace () 84 | fakeWithdrawAttackTrace = do 85 | hAdminWallet <- activateContractWallet adminWallet $ runStaking 86 | (MicroToken 9_999_999) 87 | testStakingSettings 88 | pool <- getStaking hAdminWallet 89 | void $ Emulator.waitNSlots 2 90 | 91 | hUser <- activateContractWallet user1Wallet $ userEndpoints pool 92 | hAttack <- activateContractWallet user1Wallet $ attackUserEndpoints pool 93 | 94 | void $ waitNSlots 2 95 | 96 | callEndpoint @"register" hUser () 97 | void $ waitNSlots 2 98 | 99 | callEndpoint @"deposit" hUser (MicroToken 33_333_333) 100 | void $ waitNSlots 2 101 | 102 | -- We expect that this value never change the amount of tokens in the wallet 103 | callEndpoint @"fakeWithdrawAttack" hAttack (MicroToken 2_222_222) 104 | void $ Emulator.waitNSlots 10 105 | 106 | fakeWithdrawAttackError :: [ScriptError] 107 | fakeWithdrawAttackError = pure $ 108 | EvaluationError 109 | [ "checkUserWithdraw: Datum is wrong." 110 | , "PT5" 111 | ] 112 | "CekEvaluationFailure" 113 | 114 | withdrawWithoutFeesAttackTrace :: EmulatorTrace () 115 | withdrawWithoutFeesAttackTrace = do 116 | hAdminWallet <- activateContractWallet adminWallet $ runStaking 117 | (MicroToken 9_999_999) 118 | testStakingSettings 119 | pool <- getStaking hAdminWallet 120 | void $ Emulator.waitNSlots 2 121 | 122 | hUser <- activateContractWallet user1Wallet $ userEndpoints pool 123 | hAttack <- activateContractWallet user1Wallet $ attackUserEndpoints pool 124 | 125 | void $ waitNSlots 2 126 | 127 | callEndpoint @"register" hUser () 128 | void $ waitNSlots 2 129 | 130 | callEndpoint @"deposit" hUser (MicroToken 33_333_333) 131 | void $ waitNSlots 2 132 | 133 | callEndpoint @"withdrawWithoutFeesAttack" hAttack (MicroToken 2_222_222) 134 | void $ Emulator.waitNSlots 10 135 | 136 | withdrawWithoutFeesAttackError :: [ScriptError] 137 | withdrawWithoutFeesAttackError = pure $ 138 | EvaluationError 139 | [ "checkFeesDistribution: Incentives pool fees are wrong." 140 | , "PT5" 141 | ] 142 | "CekEvaluationFailure" 143 | -------------------------------------------------------------------------------- /src/Staking/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE NoImplicitPrelude #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | 9 | {-| 10 | Module : Staking.Types 11 | Description : Types used by the staking pool and to describe each UTxO. 12 | Copyright : P2P Solutions Ltd. 13 | License : GPL-3 14 | Maintainer : laurynas@adafinance.io 15 | Stability : develop 16 | -} 17 | 18 | module Staking.Types where 19 | 20 | import Data.Aeson ( FromJSON 21 | , ToJSON 22 | ) 23 | import GHC.Generics (Generic) 24 | import qualified Prelude as HP ( Show (..) 25 | , Eq (..) 26 | ) 27 | 28 | import Ledger 29 | import qualified PlutusTx 30 | import PlutusTx.Prelude 31 | 32 | import MainToken 33 | import Staking.Business 34 | 35 | -- Characterizing the staking pool. Contract Parameter. 36 | data Staking = Staking 37 | { nft :: !AssetClass 38 | , settings :: !StakingSettings 39 | } 40 | deriving (HP.Eq, HP.Show, Generic) 41 | deriving anyclass (FromJSON, ToJSON) 42 | 43 | -- | General settings for the staking pool. 44 | data StakingSettings = StakingSettings 45 | { refWallet :: !PubKeyHash -- ^ Wallet for refilling rewards pool 46 | , daoWallet :: !PubKeyHash -- ^ Wallet for DAO program 47 | , affWallet :: !PubKeyHash -- ^ Wallet for affiliate network 48 | , opSettings :: !OperationSettings -- ^ Settings for staking operations 49 | } 50 | deriving (HP.Eq, HP.Show, Generic) 51 | deriving anyclass (FromJSON, ToJSON) 52 | 53 | -- Datum types. 54 | data StakingDatum = 55 | PoolDatum PoolState 56 | | UserDatum UserState 57 | deriving (HP.Eq, HP.Show, Generic) 58 | deriving anyclass (FromJSON, ToJSON) 59 | 60 | -- Redeemer. 61 | data StakingRedeemer = 62 | Feed !MainToken 63 | | Deposit !MainToken !POSIXTime 64 | | Withdraw !MainToken !POSIXTime 65 | | Register !PubKeyHash !AssetClass 66 | | Unregister !PubKeyHash 67 | | Claim !MainToken !POSIXTime 68 | | Compound !MainToken !POSIXTime 69 | deriving (HP.Eq, HP.Show, Generic) 70 | deriving anyclass (FromJSON, ToJSON) 71 | 72 | -- | Smart constructors for the untyped redeemers. 73 | feedRedeemer :: MainToken -> Redeemer 74 | feedRedeemer = Redeemer . PlutusTx.toBuiltinData . Feed 75 | 76 | registerRedeemer :: PubKeyHash -> AssetClass -> Redeemer 77 | registerRedeemer pkh = Redeemer . PlutusTx.toBuiltinData . Register pkh 78 | 79 | unregisterRedeemer :: PubKeyHash -> Redeemer 80 | unregisterRedeemer = Redeemer . PlutusTx.toBuiltinData . Unregister 81 | 82 | depositRedeemer :: MainToken -> POSIXTime -> Redeemer 83 | depositRedeemer mt = Redeemer . PlutusTx.toBuiltinData . Deposit mt 84 | 85 | withdrawRedeemer :: MainToken -> POSIXTime -> Redeemer 86 | withdrawRedeemer mt = Redeemer . PlutusTx.toBuiltinData . Withdraw mt 87 | 88 | claimRedeemer :: MainToken -> POSIXTime -> Redeemer 89 | claimRedeemer mt = Redeemer . PlutusTx.toBuiltinData . Claim mt 90 | 91 | compoundRedeemer :: MainToken -> POSIXTime -> Redeemer 92 | compoundRedeemer mt = Redeemer . PlutusTx.toBuiltinData . Compound mt 93 | 94 | -- Helper functions. 95 | datumIsUser :: StakingDatum -> Bool 96 | datumIsUser (UserDatum _) = True 97 | datumIsUser _ = False 98 | 99 | datumIsPool :: StakingDatum -> Bool 100 | datumIsPool (PoolDatum _) = True 101 | datumIsPool _ = False 102 | 103 | mkPoolDatum :: [(PubKeyHash, AssetClass)] -> StakingDatum 104 | mkPoolDatum = PoolDatum . mkPoolState 105 | 106 | mkUserDatum :: 107 | PubKeyHash 108 | -> [Deposit] 109 | -> Maybe POSIXTime 110 | -> StakingDatum 111 | mkUserDatum pkh dep lc = UserDatum $ mkUserState pkh dep lc 112 | 113 | mkStaking :: 114 | AssetClass 115 | -> StakingSettings 116 | -> Staking 117 | mkStaking ac s = Staking { nft = ac, settings = s } 118 | 119 | instance Eq StakingDatum where 120 | {-# INLINABLE (==) #-} 121 | PoolDatum pd1 == PoolDatum pd2 = pd1 == pd2 122 | UserDatum us1 == UserDatum us2 = us1 == us2 123 | _ == _ = False 124 | 125 | instance Eq StakingRedeemer where 126 | {-# INLINABLE (==) #-} 127 | Feed am1 == Feed am2 = am1 == am2 128 | Deposit am1 t1 == Deposit am2 t2 = am1 == am2 && t1 == t2 129 | Withdraw am1 t1 == Withdraw am2 t2 = am1 == am2 && t1 == t2 130 | Register pkh1 ac1 == Register pkh2 ac2 = pkh1 == pkh2 && ac1 == ac2 131 | Unregister pkh1 == Unregister pkh2 = pkh1 == pkh2 132 | Claim am1 t1 == Claim am2 t2 = am1 == am2 && t1 == t2 133 | Compound am1 t1 == Compound am2 t2 = am1 == am2 && t1 == t2 134 | _ == _ = False 135 | 136 | PlutusTx.makeLift ''StakingSettings 137 | PlutusTx.makeLift ''Staking 138 | PlutusTx.unstableMakeIsData ''StakingDatum 139 | PlutusTx.unstableMakeIsData ''StakingRedeemer 140 | -------------------------------------------------------------------------------- /test/Tests/TestUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | 7 | {-| 8 | Module : Tests.TestUtils 9 | Description : Common tests utils functions. 10 | Copyright : P2P Solutions Ltd. 11 | License : GPL-3 12 | Maintainer : laurynas@adafinance.io 13 | Stability : develop 14 | -} 15 | 16 | module Tests.TestUtils where 17 | 18 | -- GHC libraries. 19 | import qualified Control.Foldl as L 20 | import Control.Monad 21 | import Control.Lens ((.~)) 22 | import Control.Monad.Freer.Writer (tell) 23 | 24 | import Data.Function ((&)) 25 | import Data.Text.Prettyprint.Doc 26 | import Data.Void 27 | import Data.Default (Default (..)) 28 | import Data.Map as Map hiding (take) 29 | import Data.Monoid (Last (..)) 30 | import Data.Text 31 | 32 | import Ledger 33 | import Ledger.Ada as Ada 34 | import Ledger.Value as Value 35 | import Plutus.Trace.Emulator as Emulator 36 | import Plutus.Contract.Test 37 | import Wallet.Emulator.Folds (postMapM, failedTransactions) 38 | 39 | import Test.Tasty 40 | 41 | import Staking.Business 42 | import Staking.OffChain 43 | import Staking.Tokens 44 | import Staking.Types 45 | import MainToken 46 | 47 | runTrace :: EmulatorTrace () -> IO () 48 | runTrace = Emulator.runEmulatorTraceIO' def emCfg 49 | 50 | emCfg :: Emulator.EmulatorConfig 51 | emCfg = Emulator.EmulatorConfig 52 | { _initialChainState = 53 | Left $ Map.fromList $ [(wi, v)| wi <- Prelude.take 10 knownWallets] 54 | , _slotConfig = def 55 | , _feeConfig = def 56 | } 57 | where 58 | v :: Value 59 | v = Ada.lovelaceValueOf 10_000_000_000 60 | <> mainTokenValue 1_000_000_000 61 | 62 | getStaking :: 63 | ContractHandle (Last Staking) StakingSchema Text 64 | -> EmulatorTrace Staking 65 | getStaking h = do 66 | void $ Emulator.waitNSlots 1 67 | Last m <- observableState h 68 | case m of 69 | Nothing -> getStaking h 70 | Just pool -> return pool 71 | 72 | negativeTokenOf :: MainToken -> MainToken 73 | negativeTokenOf MicroToken{..} = MicroToken { getMicroToken = -getMicroToken } 74 | 75 | -- | Assert that exactly one transaction failed to validate, and this 76 | -- transaction that failed meet the predicate. 77 | assertFailedExactOneTx 78 | :: (Tx -> ValidationError -> [ScriptValidationEvent] -> Bool) 79 | -> TracePredicate 80 | assertFailedExactOneTx predicate = 81 | flip postMapM (L.generalize $ failedTransactions Nothing) $ \case 82 | [(_, t, e, evts)] -> return $ predicate t e evts 83 | [] -> tell @(Doc Void) "No transactions failed to validate." 84 | >> return False 85 | _ -> tell @(Doc Void) "More than one transactions failed to validate." 86 | >> return False 87 | 88 | buildTest :: String -> [ScriptError] -> EmulatorTrace () -> TestTree 89 | buildTest msg errs = 90 | checkPredicateOptions 91 | (defaultCheckOptions & emulatorConfig .~ emCfg) 92 | msg 93 | (assertFailedExactOneTx failedTx) 94 | where 95 | failedTx :: Tx -> ValidationError -> [ScriptValidationEvent] -> Bool 96 | failedTx _ (ScriptFailure scriptError) _ = scriptError `elem` errs 97 | failedTx _ _ _ = False 98 | 99 | minAda :: Integer -> Value 100 | minAda n = Ada.toValue (Ada.lovelaceOf n * Ledger.minAdaTxOut) 101 | 102 | wallet :: Int -> Wallet 103 | wallet i = knownWallets !! i 104 | 105 | adminWallet :: Wallet 106 | adminWallet = wallet 0 107 | 108 | user1Wallet :: Wallet 109 | user1Wallet = wallet 1 110 | 111 | user1WalletPKH :: PubKeyHash 112 | user1WalletPKH = walletPubKeyHash user1Wallet 113 | 114 | testStakingNFT :: Value 115 | testStakingNFT = Value.singleton testStakingNFTCS stakingNFTName 1 116 | 117 | testStakingNFTCS :: CurrencySymbol 118 | testStakingNFTCS = "67bf2a8d85a4558e483d31dac0d80285fe4ca2da2cd38e718a9b344f" 119 | 120 | testUserNFT :: Value 121 | testUserNFT = Value.singleton testUserNFTCS userNFTName 1 122 | 123 | testUserNFTCS :: CurrencySymbol 124 | testUserNFTCS = "304c2b6619389f98265cee5b6bd7a5cb74a10943eaf7d4ce21413ea5" 125 | 126 | testStaking :: Staking 127 | testStaking = mkStaking (assetClass testStakingNFTCS stakingNFTName) 128 | testStakingSettings 129 | 130 | walletPKH :: Wallet -> PubKeyHash 131 | walletPKH = walletPubKeyHash 132 | 133 | testRefWallet, testDaoWallet, testAffWallet :: Wallet 134 | testRefWallet = wallet 7 135 | testDaoWallet = wallet 8 136 | testAffWallet = wallet 9 137 | 138 | testStakingSettings :: StakingSettings 139 | testStakingSettings = StakingSettings 140 | { refWallet = walletPKH testRefWallet 141 | , daoWallet = walletPKH testDaoWallet 142 | , affWallet = walletPKH testAffWallet 143 | , opSettings = testOperationSettings 144 | } 145 | 146 | testOperationSettings :: OperationSettings 147 | testOperationSettings = OperationSettings 148 | { depositFee = 7_500 149 | , withdrawFee = 5_000 150 | , daoShare = 200_000 151 | , affShare = 300_000 152 | , minDeposit = 1_000_000 153 | , minWithdraw = 1_000_000 154 | , minClaim = 10 155 | } 156 | -------------------------------------------------------------------------------- /test/Tests/OffChain/Deposit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OffChain.Deposit 12 | Description : A test to check the behavior of the deposit operation. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OffChain.Deposit where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Control.Lens 26 | import Ledger 27 | import Plutus.Contract.Test 28 | import Plutus.V1.Ledger.Api (fromData, Data) 29 | import Plutus.Trace.Emulator as Emulator 30 | import Test.Tasty 31 | 32 | -- Internal modules. 33 | import BCExplorer as BC (printBlockChainCFD, FromDataFunc (..)) 34 | import MainToken 35 | import Staking.Business 36 | import Staking.OffChain 37 | import Staking.Validator 38 | import Staking.Types 39 | 40 | import Tests.TestUtils 41 | 42 | tests :: TestTree 43 | tests = testGroup "offChainDepositsTests" 44 | [ depositTest ] 45 | 46 | {-| Trace Summary: 47 | A staking pool is created with an initial amount of microtokens, a user 48 | registers into the staking pool, and deposits some microtokens. 49 | 50 | Trace Description: 51 | * adminWallet starts the staking pool with initialFounds microtokens. 52 | * wait 2 slots 53 | * user1Wallet registers into the staking pool. 54 | * wait 2 slots 55 | * user1Wallet deposits depositValue microtokens. 56 | * wait 10 slots 57 | -} 58 | 59 | -- The initial amount of microtokens on the staking pool. 60 | initialFounds :: Integer 61 | initialFounds = 7_777_777 62 | 63 | -- The value to be deposited by the user into the staking pool. 64 | depositValue :: Integer 65 | depositValue = 33_333_333 66 | 67 | depositTrace :: EmulatorTrace () 68 | depositTrace = do 69 | hAdminWallet <- activateContractWallet adminWallet $ 70 | runStaking (MicroToken initialFounds) testStakingSettings 71 | pool <- getStaking hAdminWallet 72 | void $ waitNSlots 2 73 | 74 | hUser1 <- activateContractWallet user1Wallet $ userEndpoints pool 75 | void $ waitNSlots 2 76 | 77 | callEndpoint @"register" hUser1 () 78 | void $ waitNSlots 2 79 | 80 | callEndpoint @"deposit" hUser1 (MicroToken depositValue) 81 | void $ waitNSlots 10 82 | 83 | BC.printBlockChainCFD [BC.FD (fromData :: Data -> Maybe StakingDatum)] 84 | 85 | 86 | {- Test Summary: 87 | Test a standard usage of the deposit operation. 88 | 89 | In this test we check that: 90 | * adminWallet has initialFounds less microtokens. 91 | * user1Wallet has depositValue microtokens less. 92 | * refWallet has refDepositFee microtokens more. 93 | * daoWallet has daoDepositFee microtokens more. 94 | * affWallet has affDepositFee microtokens more. 95 | * The staking script has the NFT plus initialFounds + depositValue 96 | - depositFees microtokens. 97 | -} 98 | depositTest :: TestTree 99 | depositTest = checkPredicateOptions 100 | (defaultCheckOptions & emulatorConfig .~ emCfg) 101 | "depositTest" 102 | ( walletFundsChange adminWallet adminWalletChangeValue 103 | .&&. walletFundsChange user1Wallet user1WalletChangeValue 104 | .&&. walletFundsChange testRefWallet refWalletChangeValue 105 | .&&. walletFundsChange testDaoWallet daoWalletChangeValue 106 | .&&. walletFundsChange testAffWallet affWalletChangeValue 107 | .&&. valueAtAddress (addressStaking testStaking) scriptValueOK 108 | ) 109 | depositTrace 110 | where 111 | user1State :: UserState 112 | user1State = mkUserState user1WalletPKH [] Nothing 113 | 114 | depositFeesDistribution :: FeesDistribution 115 | Just (_, depositFeesDistribution) = 116 | deposit user1State depositValue 0 testOperationSettings 117 | 118 | -- The distribution of fees given the deposit of 33_333_333 microtokens. 119 | -- daoDepositFees = 49_999 (20% of 249_999). 120 | -- affDepositFees = 74_999 (30% of 249_999). 121 | -- refDepositFees = 125_001 (the rest). 122 | refDepositFees, daoDepositFees, affDepositFees :: Integer 123 | refDepositFees = refillFees depositFeesDistribution 124 | daoDepositFees = daoFees depositFeesDistribution 125 | affDepositFees = affFees depositFeesDistribution 126 | 127 | -- depositFees = 249_999 with a fee of 0.75% over 33_333_333. 128 | depositFees :: Integer 129 | depositFees = refDepositFees + daoDepositFees + affDepositFees 130 | 131 | userScript :: Value 132 | userScript = 133 | testUserNFT <> mainTokenValue (depositValue - depositFees) <> minAda 1 134 | 135 | stakingScript :: Value 136 | stakingScript = testStakingNFT <> mainTokenValue initialFounds <> minAda 1 137 | 138 | scriptValueOK :: Value -> Bool 139 | scriptValueOK val = val == userScript <> stakingScript 140 | 141 | adminWalletChangeValue :: Value 142 | adminWalletChangeValue = mainTokenValue (-initialFounds) 143 | <> minAda (-1) 144 | 145 | user1WalletChangeValue :: Value 146 | user1WalletChangeValue = mainTokenValue (-depositValue) 147 | <> minAda (-4) 148 | 149 | refWalletChangeValue :: Value 150 | refWalletChangeValue = mainTokenValue refDepositFees <> minAda 1 151 | 152 | daoWalletChangeValue :: Value 153 | daoWalletChangeValue = mainTokenValue daoDepositFees <> minAda 1 154 | 155 | affWalletChangeValue :: Value 156 | affWalletChangeValue = mainTokenValue affDepositFees <> minAda 1 157 | -------------------------------------------------------------------------------- /test/Tests/OffChain/Claim.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OffChain.Claim 12 | Description : A test to verify the behavior of the claim operation. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OffChain.Claim where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Control.Lens 26 | import Ledger 27 | import Plutus.Contract.Test 28 | import Plutus.V1.Ledger.Api (fromData, Data) 29 | import Plutus.Trace.Emulator as Emulator 30 | import Test.Tasty 31 | 32 | -- Internal modules. 33 | import BCExplorer as BC (printBlockChainCFD, FromDataFunc (..)) 34 | import MainToken 35 | import Staking.Business 36 | import Staking.OffChain 37 | import Staking.Validator 38 | import Staking.Types 39 | 40 | import Tests.TestUtils 41 | 42 | tests :: TestTree 43 | tests = testGroup "offChainClaimTests" 44 | [ claimTest ] 45 | 46 | {-| Trace Summary: 47 | A staking pool is created with an initial amount of microtokens, a user 48 | registers into the staking pool, deposits some microtokens, wait a while and 49 | claim rewards. 50 | 51 | Trace Description: 52 | * adminWallet starts the staking pool with initialFounds microtokens. 53 | * wait 2 slots 54 | * user1Wallet registers into the staking pool. 55 | * wait 2 slots 56 | * user1Wallet deposits depositValue microtokens. 57 | * wait 100 slots 58 | * user1Wallet claims 59 | * wait 10 slots 60 | -} 61 | 62 | -- The initial amount of microtokens on the staking pool. 63 | initialFounds :: Integer 64 | initialFounds = 7_777_777 65 | 66 | -- The value to be deposited by the user into the staking pool. 67 | depositValue :: Integer 68 | depositValue = 33_333_333 69 | 70 | -- The expected rewards to be claimed. 71 | rews :: Integer 72 | rews = 15 73 | 74 | claimTrace :: EmulatorTrace () 75 | claimTrace = do 76 | hAdminWallet <- activateContractWallet adminWallet $ 77 | runStaking (MicroToken initialFounds) testStakingSettings 78 | pool <- getStaking hAdminWallet 79 | void $ waitNSlots 2 80 | 81 | hUser1 <- activateContractWallet user1Wallet $ userEndpoints pool 82 | void $ waitNSlots 2 83 | 84 | callEndpoint @"register" hUser1 () 85 | void $ waitNSlots 2 86 | 87 | callEndpoint @"deposit" hUser1 (MicroToken depositValue) 88 | void $ waitNSlots 100 89 | 90 | callEndpoint @"claim" hUser1 () 91 | void $ waitNSlots 10 92 | 93 | BC.printBlockChainCFD [BC.FD (fromData :: Data -> Maybe StakingDatum)] 94 | 95 | 96 | {- Test Summary: 97 | Test a standard usage of the claim operation. 98 | 99 | In this test we check that: 100 | * adminWallet has initialFounds less microtokens. 101 | * user1Wallet has depositValue microtokens less, but rews microtokens more. 102 | * refWallet has refDepositFee microtokens more. 103 | * daoWallet has daoDepositFee microtokens more. 104 | * affWallet has affDepositFee microtokens more. 105 | * The staking script has the NFT plus initialFounds - rews + depositValue 106 | - depositFees microtokens. 107 | -} 108 | claimTest :: TestTree 109 | claimTest = checkPredicateOptions 110 | (defaultCheckOptions & emulatorConfig .~ emCfg) 111 | "claimTest" 112 | ( walletFundsChange adminWallet adminWalletChangeValue 113 | .&&. walletFundsChange user1Wallet user1WalletChangeValue 114 | .&&. walletFundsChange testRefWallet refWalletChangeValue 115 | .&&. walletFundsChange testDaoWallet daoWalletChangeValue 116 | .&&. walletFundsChange testAffWallet affWalletChangeValue 117 | .&&. valueAtAddress (addressStaking testStaking) scriptValueOK 118 | ) 119 | claimTrace 120 | where 121 | user1State :: UserState 122 | user1State = mkUserState user1WalletPKH [] Nothing 123 | 124 | depositFeesDistribution :: FeesDistribution 125 | Just (_, depositFeesDistribution) = 126 | deposit user1State depositValue 0 testOperationSettings 127 | 128 | -- The distribution of fees given the deposit of 33_333_333 microtokens. 129 | -- daoDepositFees = 49_999 (20% of 249_999). 130 | -- affDepositFees = 74_999 (30% of 249_999). 131 | -- refDepositFees = 125_001 (the rest). 132 | refDepositFees, daoDepositFees, affDepositFees :: Integer 133 | refDepositFees = refillFees depositFeesDistribution 134 | daoDepositFees = daoFees depositFeesDistribution 135 | affDepositFees = affFees depositFeesDistribution 136 | 137 | -- totalDepositFees = 249_999 with a fee of 0.75% over 33_333_333. 138 | depositFees :: Integer 139 | depositFees = refDepositFees + daoDepositFees + affDepositFees 140 | 141 | userScript :: Value 142 | userScript = 143 | testUserNFT <> mainTokenValue (depositValue - depositFees) <> minAda 1 144 | 145 | stakingScript :: Value 146 | stakingScript = 147 | testStakingNFT <> mainTokenValue (initialFounds - rews) <> minAda 1 148 | 149 | scriptValueOK :: Value -> Bool 150 | scriptValueOK val = val == userScript <> stakingScript 151 | 152 | adminWalletChangeValue :: Value 153 | adminWalletChangeValue = mainTokenValue (-initialFounds) 154 | <> minAda (-1) 155 | 156 | user1WalletChangeValue :: Value 157 | user1WalletChangeValue = mainTokenValue (-depositValue + rews) 158 | <> minAda (-4) 159 | 160 | refWalletChangeValue :: Value 161 | refWalletChangeValue = mainTokenValue refDepositFees <> minAda 1 162 | 163 | daoWalletChangeValue :: Value 164 | daoWalletChangeValue = mainTokenValue daoDepositFees <> minAda 1 165 | 166 | affWalletChangeValue :: Value 167 | affWalletChangeValue = mainTokenValue affDepositFees <> minAda 1 168 | -------------------------------------------------------------------------------- /test/Tests/OffChain/Compound.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OffChain.Compound 12 | Description : A test to check the behavior of the compound operation. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OffChain.Compound where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Control.Lens 26 | import Ledger 27 | import Plutus.Contract.Test 28 | import Plutus.V1.Ledger.Api (fromData, Data) 29 | import Plutus.Trace.Emulator as Emulator 30 | import Test.Tasty 31 | 32 | -- Internal modules. 33 | import BCExplorer as BC (printBlockChainCFD, FromDataFunc (..)) 34 | import MainToken 35 | import Staking.Business 36 | import Staking.OffChain 37 | import Staking.Validator 38 | import Staking.Types 39 | 40 | import Tests.TestUtils 41 | 42 | tests :: TestTree 43 | tests = testGroup "offChainCompoundTests" 44 | [ compoundTest ] 45 | 46 | {-| Trace Summary: 47 | A staking pool is created with an initial amount of microtokens, a user 48 | registers into the staking pool, deposits some microtokens, wait a while and 49 | compound the rewards. 50 | 51 | Trace Description: 52 | * adminWallet starts the staking pool with initialFounds microtokens. 53 | * wait 2 slots 54 | * user1Wallet registers into the staking pool. 55 | * wait 2 slots 56 | * user1Wallet deposits depositValue microtokens. 57 | * wait 100 slots 58 | * user1Wallet compound 59 | * wait 10 slots 60 | -} 61 | 62 | -- The initial amount of microtokens on the staking pool. 63 | initialFounds :: Integer 64 | initialFounds = 7_777_777 65 | 66 | -- The value to be deposited by the user into the staking pool. 67 | depositValue :: Integer 68 | depositValue = 33_333_333 69 | 70 | -- The expected rewards to be claimed. 71 | rews :: Integer 72 | rews = 15 73 | 74 | compoundTrace :: EmulatorTrace () 75 | compoundTrace = do 76 | hAdminWallet <- activateContractWallet adminWallet $ 77 | runStaking (MicroToken initialFounds) testStakingSettings 78 | 79 | pool <- getStaking hAdminWallet 80 | void $ waitNSlots 2 81 | 82 | hUser1 <- activateContractWallet user1Wallet $ userEndpoints pool 83 | void $ waitNSlots 2 84 | 85 | callEndpoint @"register" hUser1 () 86 | void $ waitNSlots 2 87 | 88 | callEndpoint @"deposit" hUser1 (MicroToken depositValue) 89 | void $ waitNSlots 100 90 | 91 | callEndpoint @"compound" hUser1 () 92 | void $ waitNSlots 10 93 | 94 | BC.printBlockChainCFD [BC.FD (fromData :: Data -> Maybe StakingDatum)] 95 | 96 | 97 | {- Test Summary: 98 | Test a standard usage of the compound operation. 99 | 100 | In this test we check that: 101 | * adminWallet has initialFounds less microtokens. 102 | * user1Wallet has depositValue microtokens less. 103 | * refWallet has refDepositFee microtokens more. 104 | * daoWallet has daoDepositFee microtokens more. 105 | * affWallet has affDepositFee microtokens more. 106 | * The staking script has the NFT plus initialFounds + depositValue 107 | - totalDepositFees microtokens. 108 | -} 109 | compoundTest :: TestTree 110 | compoundTest = checkPredicateOptions 111 | (defaultCheckOptions & emulatorConfig .~ emCfg) 112 | "compoundTest" 113 | ( walletFundsChange adminWallet adminWalletChangeValue 114 | .&&. walletFundsChange user1Wallet user1WalletChangeValue 115 | .&&. walletFundsChange testRefWallet refWalletChangeValue 116 | .&&. walletFundsChange testDaoWallet daoWalletChangeValue 117 | .&&. walletFundsChange testAffWallet affWalletChangeValue 118 | .&&. valueAtAddress (addressStaking testStaking) scriptValueOK 119 | ) 120 | compoundTrace 121 | where 122 | user1State :: UserState 123 | user1State = mkUserState user1WalletPKH [] Nothing 124 | 125 | depositFees :: FeesDistribution 126 | Just (_, depositFees) = 127 | deposit user1State depositValue 0 testOperationSettings 128 | 129 | -- The distribution of fees given the deposit of 33_333_333 microtokens. 130 | -- daoDepositFees = 49_999 (20% of 249_999). 131 | -- affDepositFees = 74_999 (30% of 249_999). 132 | -- refDepositFees = 125_001 (the rest). 133 | refDepositFees, daoDepositFees, affDepositFees :: Integer 134 | refDepositFees = refillFees depositFees 135 | daoDepositFees = daoFees depositFees 136 | affDepositFees = affFees depositFees 137 | 138 | -- totalDepositFees = 249_999 with a fee of 0.75% over 33_333_333. 139 | totalDepositFees :: Integer 140 | totalDepositFees = refDepositFees + daoDepositFees + affDepositFees 141 | 142 | userScript :: Value 143 | userScript = testUserNFT -- 33_083_349 = 33_333_333 - 249_999 + 15 144 | <> mainTokenValue (depositValue - totalDepositFees + rews) 145 | <> minAda 1 146 | 147 | stakingScript :: Value 148 | stakingScript = testStakingNFT 149 | <> mainTokenValue (initialFounds - rews) <> minAda 1 150 | 151 | scriptValueOK :: Value -> Bool 152 | scriptValueOK val = val == userScript <> stakingScript 153 | 154 | adminWalletChangeValue :: Value 155 | adminWalletChangeValue = mainTokenValue (-initialFounds) 156 | <> minAda (-1) 157 | 158 | user1WalletChangeValue :: Value 159 | user1WalletChangeValue = mainTokenValue (-depositValue) 160 | <> minAda (-4) 161 | 162 | refWalletChangeValue :: Value 163 | refWalletChangeValue = mainTokenValue refDepositFees <> minAda 1 164 | 165 | daoWalletChangeValue :: Value 166 | daoWalletChangeValue = mainTokenValue daoDepositFees <> minAda 1 167 | 168 | affWalletChangeValue :: Value 169 | affWalletChangeValue = mainTokenValue affDepositFees <> minAda 1 170 | -------------------------------------------------------------------------------- /src/Utils/ScriptContext.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | {-| 5 | Module : Utils.ScriptContext 6 | Description : Useful functions about script contexts. 7 | Copyright : P2P Solutions Ltd. 8 | License : GPL-3 9 | Maintainer : laurynas@adafinance.io 10 | Stability : develop 11 | 12 | Common functions for manipulating script context. 13 | -} 14 | 15 | module Utils.ScriptContext where 16 | 17 | import qualified PlutusTx 18 | import PlutusTx.Prelude hiding (Semigroup(..) 19 | , unless, mapMaybe, find 20 | ) 21 | import Ledger hiding (singleton) 22 | import Ledger.Value as Value 23 | 24 | -- | Gets all utxo inputs corresponding with address addr. 25 | {-# INLINABLE getTxInputs #-} 26 | getTxInputs :: Address -> ScriptContext -> [TxInInfo] 27 | getTxInputs addr ctx = [ i | i <- txInfoInputs info 28 | , txOutAddress (txInInfoResolved i) == addr 29 | ] 30 | where 31 | info = scriptContextTxInfo ctx 32 | 33 | -- | Gets all utxo outputs corresponding with address addr. 34 | {-# INLINABLE getTxOutputs #-} 35 | getTxOutputs :: Address -> ScriptContext -> [TxOut] 36 | getTxOutputs addr ctx = [ o | o <- txInfoOutputs info 37 | , txOutAddress o == addr 38 | ] 39 | where 40 | info = scriptContextTxInfo ctx 41 | 42 | -- | Gets all utxo inputs with script addresses. 43 | {-# INLINABLE getAllScriptInputs #-} 44 | getAllScriptInputs :: ScriptContext -> [TxInInfo] 45 | getAllScriptInputs = 46 | filterInputs (isJust . toValidatorHash . txOutAddress . txInInfoResolved) 47 | 48 | -- | Gets all utxo inputs with public key addresses. 49 | {-# INLINABLE getAllWalletInputs #-} 50 | getAllWalletInputs :: ScriptContext -> [TxInInfo] 51 | getAllWalletInputs = 52 | filterInputs (isJust . toValidatorHash . txOutAddress . txInInfoResolved) 53 | 54 | -- | Filter utxo inputs. 55 | {-# INLINABLE filterInputs #-} 56 | filterInputs :: (TxInInfo -> Bool) -> ScriptContext -> [TxInInfo] 57 | filterInputs f = filter f . (txInfoInputs . scriptContextTxInfo) 58 | 59 | -- | Obtains the unique script utxo which has the corresponding NFT. 60 | getTxInFromNFT :: ScriptContext -> AssetClass -> Maybe TxInInfo 61 | getTxInFromNFT ctx nft = 62 | case filterInputs (checkTxHasNFT nft . txInInfoResolved) ctx of 63 | [o] -> Just o 64 | _ -> Nothing 65 | 66 | -- | Filter utxo outputs. 67 | {-# INLINABLE filterOutputs #-} 68 | filterOutputs :: (TxOut -> Bool) -> ScriptContext -> [TxOut] 69 | filterOutputs f = filter f . (txInfoOutputs . scriptContextTxInfo) 70 | 71 | -- | Filter all the utxo outputs that pay to the same script address 72 | -- that we are currently spending from. 73 | {-# INLINABLE filterContinuingOutputs #-} 74 | filterContinuingOutputs 75 | :: (TxOut -> Bool) 76 | -> ScriptContext 77 | -> [TxOut] 78 | filterContinuingOutputs f = filter f . getContinuingOutputs 79 | 80 | -- | Obtains the unique script utxo which has the corresponding NFT. 81 | getTxOutFromNFT :: ScriptContext -> AssetClass -> Maybe TxOut 82 | getTxOutFromNFT ctx nft = 83 | case filterContinuingOutputs (checkTxHasNFT nft) ctx of 84 | [o] -> Just o 85 | _ -> Nothing 86 | 87 | -- | Checks that a transaction has attached the specified NFT. 88 | {-# INLINABLE checkTxHasNFT #-} 89 | checkTxHasNFT :: AssetClass -> TxOut -> Bool 90 | checkTxHasNFT asc o = assetClassValueOf (txOutValue o) asc == 1 91 | 92 | -- | Checks that the own script input contains the specified NFT. 93 | {-# INLINABLE inputHasNFT #-} 94 | inputHasNFT :: AssetClass -> ScriptContext -> Bool 95 | inputHasNFT asc = 96 | maybe (traceError "script input missing") 97 | (checkTxHasNFT asc . txInInfoResolved) . findOwnInput 98 | 99 | -- | Checks that the own script output contains the specified NFT. 100 | {-# INLINABLE outputHasNFT #-} 101 | outputHasNFT :: AssetClass -> ScriptContext -> Bool 102 | outputHasNFT asc = maybe (traceError "script unique own output missing") 103 | (checkTxHasNFT asc) . uniqueScriptOutput 104 | 105 | -- | Gets the datum attached to a utxo. 106 | {-# INLINABLE getTxDatum #-} 107 | getTxDatum :: PlutusTx.FromData d => TxOut -> ScriptContext -> Maybe d 108 | getTxDatum o ctx = txOutDatum o >>= (`findDatum` scriptContextTxInfo ctx) 109 | >>= PlutusTx.fromBuiltinData . getDatum 110 | 111 | -- | Obtains the unique script utxo if there exists. 112 | {-# INLINABLE uniqueScriptOutput #-} 113 | uniqueScriptOutput :: ScriptContext -> Maybe TxOut 114 | uniqueScriptOutput ctx = case getContinuingOutputs ctx of 115 | [o] -> Just o 116 | _ -> Nothing 117 | 118 | -- | Check the value of the unique script input and output doesn't changed. 119 | {-# INLINABLE unchangedValueFromNFT #-} 120 | unchangedValueFromNFT :: ScriptContext -> AssetClass -> Bool 121 | unchangedValueFromNFT ctx asc = 122 | traceIfFalse "unchangedValueFromNFT: Changed value" $ inVal == outVal 123 | where 124 | inVal :: Value 125 | inVal = maybe 126 | (traceError "unchangedValueFromNFT inVal: missing utxo input") 127 | (txOutValue . txInInfoResolved) 128 | (findOwnInput ctx) 129 | 130 | outVal :: Value 131 | outVal = maybe 132 | (traceError "unchangedValueFromNFT outVal: missing utxo output") 133 | txOutValue 134 | (getTxOutFromNFT ctx asc) 135 | 136 | -- | Check the value of the unique script input and output doesn't changed. 137 | {-# INLINABLE unchangedValue #-} 138 | unchangedValue :: ScriptContext -> Bool 139 | unchangedValue ctx = 140 | traceIfFalse "unchangedValue: Changed value" $ inVal == outVal 141 | where 142 | inVal :: Value 143 | inVal = maybe (traceError "unchangedValue inVal: missing utxo input") 144 | (txOutValue . txInInfoResolved) 145 | (findOwnInput ctx) 146 | 147 | outVal :: Value 148 | outVal = maybe (traceError "unchangedValue outVal: missing utxo output") 149 | txOutValue 150 | (uniqueScriptOutput ctx) 151 | 152 | -- | Obtains the UTxO being spent with the corresponding NFT. 153 | {-# INLINABLE findSpentTxOut #-} 154 | findSpentTxOut :: ScriptContext -> AssetClass -> Maybe TxOut 155 | findSpentTxOut ctx ac = txInInfoResolved <$> getTxInFromNFT ctx ac 156 | -------------------------------------------------------------------------------- /test/Tests/Attacks/Compound.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | {-| 9 | Module : Tests.Attacks.Compound 10 | Description : A new off-chain code to test an attack the compound validator. 11 | Copyright : P2P Solutions Ltd. 12 | License : GPL-3 13 | Maintainer : laurynas@adafinance.io 14 | Stability : develop 15 | -} 16 | 17 | module Tests.Attacks.Compound 18 | ( AttackSchema 19 | -- ^ Endpoints 20 | , attackUserEndpoints 21 | ) where 22 | 23 | import Control.Monad 24 | import Data.Monoid (Last (..)) 25 | import Data.Text as T (Text) 26 | 27 | -- Third-party libraries libraries. 28 | import Ledger hiding (singleton) 29 | import Ledger.Constraints as Constraints 30 | import Plutus.Contract as Contract 31 | import PlutusTx 32 | 33 | -- Internal modules. 34 | import MainToken 35 | import Staking.Business 36 | import Staking.Types 37 | import Utils.OffChain 38 | import Tests.Attacks.AttackUtils 39 | 40 | -- Schema. 41 | type AttackSchema = 42 | Endpoint "compoundAttack" () -- Claim and steal more than excpeted 43 | .\/ Endpoint "fakeCompoundAttack" () -- Compound without updating lastClaim 44 | 45 | attackUserEndpoints :: Staking -> Contract (Last Staking) AttackSchema Text () 46 | attackUserEndpoints staking = forever $ handleError logError $ awaitPromise $ 47 | compoundAttackEndpoint `select` 48 | fakeCompoundAttackEndpoint 49 | where 50 | compoundAttackEndpoint :: Promise (Last Staking) AttackSchema Text () 51 | compoundAttackEndpoint = 52 | endpoint @"compoundAttack" $ const $ compoundAttack staking 53 | 54 | fakeCompoundAttackEndpoint :: Promise (Last Staking) AttackSchema Text () 55 | fakeCompoundAttackEndpoint = 56 | endpoint @"fakeCompoundAttack" $ const $ fakeCompoundAttack staking 57 | 58 | 59 | compoundAttack :: Staking -> Contract w s Text () 60 | compoundAttack staking@Staking{..} = do 61 | cTime <- currentTime 62 | ownPKH <- Contract.ownPubKeyHash 63 | (orefStaking, oStaking) <- findStaking staking 64 | (orefUser, oUser) <- findUserUTxO staking ownPKH 65 | activeUsers <- getPoolState oStaking 66 | oldUserState <- getUserState oUser 67 | 68 | let compoundRes = compound oldUserState cTime (opSettings settings) 69 | 70 | case compoundRes of 71 | Nothing -> logInfo @String $ 72 | "Claimable rewards do not yet reach the minimum ammount." 73 | Just (newUserState, rews) -> do 74 | void $ checkMinFundsPoolUTxO staking rews 75 | let oldStakingVal = getChainIndexTxOutValue oStaking 76 | newStakingVal = oldStakingVal <> mainTokenValue (-2*rews) 77 | newStakingDat = PoolDatum activeUsers 78 | newUserDatum = 79 | UserDatum newUserState { deposits = (cTime, rews) : 80 | deposits newUserState } 81 | 82 | oldUserVal = getChainIndexTxOutValue oUser 83 | newUserVal = oldUserVal <> mainTokenValue (2*rews) 84 | 85 | range = interval cTime (cTime + validTimeRange) 86 | red = Redeemer $ PlutusTx.toBuiltinData $ 87 | Compound (MicroToken { getMicroToken = 2*rews }) 88 | cTime 89 | lookups = mkLookups staking [ (orefStaking, oStaking) 90 | , (orefUser, oUser) 91 | ] 92 | 93 | tx = Constraints.mustSpendScriptOutput orefStaking red 94 | <> Constraints.mustSpendScriptOutput orefUser red 95 | <> Constraints.mustPayToTheScript newStakingDat newStakingVal 96 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 97 | <> Constraints.mustValidateIn range 98 | 99 | submittedTx <- submitTxConstraintsWith lookups tx 100 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 101 | logInfo @String $ "User has compounded their rewards (" ++ 102 | show (2*rews) ++ " micro MyToken)." 103 | 104 | fakeCompoundAttack :: Staking -> Contract w s Text () 105 | fakeCompoundAttack staking@Staking{..} = do 106 | cTime <- currentTime 107 | ownPKH <- Contract.ownPubKeyHash 108 | (orefStaking, oStaking) <- findStaking staking 109 | (orefUser, oUser) <- findUserUTxO staking ownPKH 110 | activeUsers <- getPoolState oStaking 111 | oldUserState <- getUserState oUser 112 | 113 | let compoundRes = compound oldUserState cTime (opSettings settings) 114 | 115 | case compoundRes of 116 | Nothing -> logInfo @String $ 117 | "Claimable rewards do not yet reach the minimum ammount." 118 | Just (newUserState, rews) -> do 119 | void $ checkMinFundsPoolUTxO staking rews 120 | let oldStakingVal = getChainIndexTxOutValue oStaking 121 | newStakingVal = oldStakingVal <> mainTokenValue (-rews) 122 | newStakingDat = PoolDatum activeUsers 123 | newUserDatum = UserDatum newUserState {lastClaim = Nothing} 124 | 125 | oldUserVal = getChainIndexTxOutValue oUser 126 | newUserVal = oldUserVal <> mainTokenValue rews 127 | 128 | range = interval cTime (cTime + validTimeRange) 129 | red = Redeemer $ PlutusTx.toBuiltinData $ 130 | Compound (MicroToken { getMicroToken = rews }) 131 | cTime 132 | lookups = mkLookups staking [ (orefStaking, oStaking) 133 | , (orefUser, oUser) ] 134 | tx = Constraints.mustSpendScriptOutput orefStaking red 135 | <> Constraints.mustSpendScriptOutput orefUser red 136 | <> Constraints.mustPayToTheScript newStakingDat newStakingVal 137 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 138 | <> Constraints.mustValidateIn range 139 | 140 | submittedTx <- submitTxConstraintsWith lookups tx 141 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 142 | logInfo @String $ "User has compounded their rewards (" ++ 143 | show (2*rews) ++ " micro MyToken)." 144 | -------------------------------------------------------------------------------- /test/Tests/OffChain/Withdraw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OffChain.Withdraw 12 | Description : A test to check the behavior of the withdraw operation. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OffChain.Withdraw where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Control.Lens 26 | import Ledger 27 | import Plutus.Contract.Test 28 | import Plutus.V1.Ledger.Api (fromData, Data) 29 | import Plutus.Trace.Emulator as Emulator 30 | import Test.Tasty 31 | 32 | -- Internal modules. 33 | import BCExplorer as BC (printBlockChainCFD, FromDataFunc (..)) 34 | import MainToken 35 | import Staking.Business 36 | import Staking.OffChain 37 | import Staking.Validator 38 | import Staking.Types 39 | 40 | import Tests.TestUtils 41 | 42 | tests :: TestTree 43 | tests = testGroup "offChainWithdrawnTests" 44 | [ withdrawTest ] 45 | 46 | {-| Trace Summary: 47 | A staking pool is created with an initial amount of microtokens, a user 48 | registers into the staking pool, deposits some microtokens, and withdraw an 49 | amount. 50 | 51 | Trace Description: 52 | * adminWallet starts the staking pool with initialFounds microtokens. 53 | * wait 2 slots 54 | * user1Wallet registers into the staking pool. 55 | * wait 2 slots 56 | * user1Wallet deposits depositValue microtokens. 57 | * wait 2 slots 58 | * user1Wallet withdraw withdrawValue microtokens. 59 | * wait 10 slots 60 | -} 61 | 62 | -- The initial amount of microtokens on the staking pool. 63 | initialFounds :: Integer 64 | initialFounds = 7_777_777 65 | 66 | -- The value to be deposited by the user into the staking pool. 67 | depositValue :: Integer 68 | depositValue = 33_333_333 69 | 70 | -- The value withdrawn by the user. 71 | withdrawValue :: Integer 72 | withdrawValue = 29_999_999 73 | 74 | withdrawTrace :: EmulatorTrace () 75 | withdrawTrace = do 76 | hAdminWallet <- activateContractWallet adminWallet $ 77 | runStaking (MicroToken initialFounds) testStakingSettings 78 | pool <- getStaking hAdminWallet 79 | void $ waitNSlots 2 80 | hUser1 <- activateContractWallet user1Wallet $ userEndpoints pool 81 | void $ waitNSlots 2 82 | callEndpoint @"register" hUser1 () 83 | void $ waitNSlots 2 84 | callEndpoint @"deposit" hUser1 (MicroToken depositValue) 85 | void $ waitNSlots 2 86 | callEndpoint @"withdraw" hUser1 (MicroToken withdrawValue) 87 | void $ waitNSlots 10 88 | 89 | BC.printBlockChainCFD [BC.FD (fromData :: Data -> Maybe StakingDatum)] 90 | 91 | 92 | {- Test Summary: 93 | Test a standard usage of the withdraw operation. 94 | 95 | In this test we check that: 96 | * adminWallet has initialFounds less microtokens. 97 | * user1Wallet has depositValue and withdrawFees microtokens less, but rews 98 | microtokens more. 99 | * refWallet has refDepositFee microtokens more. 100 | * daoWallet has daoDepositFee microtokens more. 101 | * affWallet has affDepositFee microtokens more. 102 | * The staking script has the NFT plus initialFounds + depositValue 103 | - depositFees - withdrawValue microtokens. 104 | -} 105 | withdrawTest :: TestTree 106 | withdrawTest = checkPredicateOptions 107 | (defaultCheckOptions & emulatorConfig .~ emCfg) 108 | "withdrawTest" 109 | ( walletFundsChange adminWallet adminWalletChangeValue 110 | .&&. walletFundsChange user1Wallet user1WalletChangeValue 111 | .&&. walletFundsChange testRefWallet refWalletChangeValue 112 | .&&. walletFundsChange testDaoWallet daoWalletChangeValue 113 | .&&. walletFundsChange testAffWallet affWalletChangeValue 114 | .&&. valueAtAddress (addressStaking testStaking) scriptValueOK 115 | ) 116 | withdrawTrace 117 | where 118 | user1State :: UserState 119 | user1State = mkUserState user1WalletPKH [] Nothing 120 | 121 | depositFeesDistribution :: FeesDistribution 122 | Just (newUser1State, depositFeesDistribution) = 123 | deposit user1State depositValue 0 testOperationSettings 124 | 125 | -- The distribution of fees given the deposit of 33_333_333 microtokens. 126 | -- daoDepositFees = 49_999 (20% of 416_666). 127 | -- affDepositFees = 74_999 (30% of 416_666). 128 | -- refDepositFees = 125_001 (the rest). 129 | refDepositFees, daoDepositFees, affDepositFees :: Integer 130 | refDepositFees = refillFees depositFeesDistribution 131 | daoDepositFees = daoFees depositFeesDistribution 132 | affDepositFees = affFees depositFeesDistribution 133 | 134 | -- depositFees = 249_999 with a fee of 0.75% over 33_333_333. 135 | depositFees :: Integer 136 | depositFees = refDepositFees + daoDepositFees + affDepositFees 137 | 138 | withdrawFeesDistribution :: FeesDistribution 139 | Just (_, withdrawFeesDistribution) = 140 | withdraw newUser1State withdrawValue testOperationSettings 141 | 142 | -- The distribution of fees given the withdraw of 29_999_999 microtokens. 143 | -- daoDepositFees = 29_999 (20% of 149_999). 144 | -- affDepositFees = 44_999 (30% of 149_999). 145 | -- refDepositFees = 75_001 (the rest). 146 | refWithdrawFees, daoWithdrawFees, affWithdrawFees :: Integer 147 | refWithdrawFees = refillFees withdrawFeesDistribution 148 | daoWithdrawFees = daoFees withdrawFeesDistribution 149 | affWithdrawFees = affFees withdrawFeesDistribution 150 | 151 | -- withdrawFees = 149_999 with a fee of 0.5% over 29_999_999. 152 | withdrawFees :: Integer 153 | withdrawFees = refWithdrawFees + daoWithdrawFees + affWithdrawFees 154 | 155 | finalExpectedValue :: Integer 156 | finalExpectedValue = -depositValue + withdrawValue - withdrawFees 157 | 158 | userScript :: Value 159 | userScript = testUserNFT 160 | <> mainTokenValue (depositValue - depositFees - withdrawValue) 161 | <> minAda 1 162 | 163 | stakingScript :: Value 164 | stakingScript = testStakingNFT <> mainTokenValue initialFounds <> minAda 1 165 | 166 | scriptValueOK :: Value -> Bool 167 | scriptValueOK val = val == userScript <> stakingScript 168 | 169 | adminWalletChangeValue :: Value 170 | adminWalletChangeValue = mainTokenValue (-initialFounds) <> minAda (-1) 171 | 172 | user1WalletChangeValue :: Value 173 | user1WalletChangeValue = mainTokenValue finalExpectedValue <> minAda (-7) 174 | 175 | refWalletChangeValue :: Value 176 | refWalletChangeValue = 177 | mainTokenValue (refDepositFees + refWithdrawFees) <> minAda 2 178 | 179 | daoWalletChangeValue :: Value 180 | daoWalletChangeValue = 181 | mainTokenValue (daoDepositFees + daoWithdrawFees) <> minAda 2 182 | 183 | affWalletChangeValue :: Value 184 | affWalletChangeValue = 185 | mainTokenValue (affDepositFees + affWithdrawFees) <> minAda 2 186 | -------------------------------------------------------------------------------- /test/Tests/OffChain/Unregister.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NumericUnderscores #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | {-| 11 | Module : Tests.OffChain.Unregister 12 | Description : Tests to check the behavior of the unregister operation. 13 | Copyright : P2P Solutions Ltd. 14 | License : GPL-3 15 | Maintainer : laurynas@adafinance.io 16 | Stability : develop 17 | -} 18 | 19 | module Tests.OffChain.Unregister where 20 | 21 | -- GHC libraries. 22 | import Control.Monad 23 | 24 | -- Third-praty libraries. 25 | import Control.Lens 26 | import Ledger 27 | import Plutus.Contract.Test 28 | import Plutus.V1.Ledger.Api (fromData, Data) 29 | import Plutus.Trace.Emulator as Emulator 30 | import Test.Tasty 31 | 32 | -- Internal modules. 33 | import BCExplorer as BC (printBlockChainCFD, FromDataFunc (..)) 34 | import MainToken 35 | import Staking.Business 36 | import Staking.OffChain 37 | import Staking.Validator 38 | import Staking.Types 39 | 40 | import Tests.TestUtils 41 | 42 | tests :: TestTree 43 | tests = testGroup "offChainUnregisterTests" 44 | [ unregisterTest 45 | , failedUnregisterTest 46 | ] 47 | 48 | {-| Trace Summary: 49 | A staking pool is created with an initial amount of microtokens, a user 50 | registers into the staking pool, deposits some microtokens, and unregister 51 | from the staking pool successfully. 52 | 53 | Trace Description: 54 | * adminWallet starts the staking pool with initialFounds microtokens. 55 | * wait 2 slots. 56 | * user1Wallet registers into the staking pool. 57 | * wait 2 slots. 58 | * user1Wallet unregisters from the staking pool. 59 | * wait 10 slots. 60 | -} 61 | 62 | -- The initial amount of microtokens on the staking pool. 63 | initialFounds :: Integer 64 | initialFounds = 7_777_777 65 | 66 | unregisterTrace :: EmulatorTrace () 67 | unregisterTrace = do 68 | hAdminWallet <- activateContractWallet adminWallet $ 69 | runStaking (MicroToken initialFounds) testStakingSettings 70 | pool <- getStaking hAdminWallet 71 | void $ waitNSlots 2 72 | 73 | hUser1 <- activateContractWallet user1Wallet $ userEndpoints pool 74 | void $ waitNSlots 2 75 | 76 | callEndpoint @"register" hUser1 () 77 | void $ waitNSlots 2 78 | 79 | callEndpoint @"unregister" hUser1 () 80 | void $ waitNSlots 10 81 | 82 | BC.printBlockChainCFD [BC.FD (fromData :: Data -> Maybe StakingDatum)] 83 | 84 | {- Test Summary: 85 | Test a standard usage of the unregister operation. 86 | 87 | In this test we check that: 88 | * adminWallet has initialFounds less microtokens. 89 | * The staking script has the NFT plus initialFounds microtokens. 90 | -} 91 | unregisterTest :: TestTree 92 | unregisterTest = checkPredicateOptions 93 | (defaultCheckOptions & emulatorConfig .~ emCfg) 94 | "unregisterTest" 95 | ( walletFundsChange adminWallet (mainTokenValue (-initialFounds) 96 | <> minAda (-1)) 97 | .&&. valueAtAddress (addressStaking testStaking) scriptValueOK 98 | ) 99 | unregisterTrace 100 | where 101 | stakingScript :: Value 102 | stakingScript = testStakingNFT <> mainTokenValue initialFounds <> minAda 1 103 | 104 | scriptValueOK :: Value -> Bool 105 | scriptValueOK val = val == stakingScript 106 | 107 | 108 | {-| Trace Summary: 109 | A staking pool is created with an initial amount of microtokens, a user 110 | registers into the staking pool, deposits some microtokens, and try to 111 | unregister from the staking pool without success. 112 | 113 | Trace Description: 114 | * adminWallet starts the staking pool with initialFounds microtokens. 115 | * wait 2 slots. 116 | * user1Wallet registers into the staking pool. 117 | * wait 2 slots. 118 | * user1Wallet deposits depositValue microtokens. 119 | * wait 2 slots. 120 | * user1Wallet try to unregister from the staking pool. 121 | * wait 10 slots. 122 | -} 123 | 124 | -- The value deposited by the user into the staking pool. 125 | depositValue :: Integer 126 | depositValue = 33_333_333 127 | 128 | failedUnregisterTrace :: EmulatorTrace () 129 | failedUnregisterTrace = do 130 | hAdminWallet <- activateContractWallet adminWallet $ 131 | runStaking (MicroToken initialFounds) testStakingSettings 132 | pool <- getStaking hAdminWallet 133 | void $ waitNSlots 2 134 | 135 | hUser1 <- activateContractWallet user1Wallet $ userEndpoints pool 136 | void $ waitNSlots 2 137 | 138 | callEndpoint @"register" hUser1 () 139 | void $ waitNSlots 2 140 | 141 | callEndpoint @"deposit" hUser1 (MicroToken depositValue) 142 | void $ waitNSlots 2 143 | 144 | callEndpoint @"unregister" hUser1 () 145 | void $ waitNSlots 10 146 | 147 | BC.printBlockChainCFD [BC.FD (fromData :: Data -> Maybe StakingDatum)] 148 | 149 | 150 | {- Test Summary: 151 | The following test is similar to the previous one, with an added call to 152 | deposit, which must fail because user 1 has not withdrawn all their staked 153 | MyToken. For this reason, the balance in the end must be exactly as in 154 | depositTest, which in this case means that user UTxO has been untouched. 155 | 156 | In this test we check that: 157 | * adminWallet has initialFounds less microtokens. 158 | * user1Wallet has depositValue microtokens less. 159 | * refWallet has refDepositFee microtokens more. 160 | * daoWallet has daoDepositFee microtokens more. 161 | * affWallet has affDepositFee microtokens more. 162 | * The staking script has the NFT plus initialFounds + depositValue 163 | - depositFees microtokens. 164 | -} 165 | failedUnregisterTest :: TestTree 166 | failedUnregisterTest = checkPredicateOptions 167 | (defaultCheckOptions & emulatorConfig .~ emCfg) 168 | "failedUnregisterTest" 169 | ( walletFundsChange adminWallet adminWalletChangeValue 170 | .&&. walletFundsChange user1Wallet user1WalletChangeValue 171 | .&&. walletFundsChange testRefWallet refWalletChangeValue 172 | .&&. walletFundsChange testDaoWallet daoWalletChangeValue 173 | .&&. walletFundsChange testAffWallet affWalletChangeValue 174 | .&&. valueAtAddress (addressStaking testStaking) scriptValueOK 175 | ) 176 | failedUnregisterTrace 177 | where 178 | user1State :: UserState 179 | user1State = mkUserState user1WalletPKH [] Nothing 180 | 181 | depositFeesDistribution :: FeesDistribution 182 | Just (_, depositFeesDistribution) = 183 | deposit user1State depositValue 0 testOperationSettings 184 | 185 | -- The distribution of fees given the deposit of 33_333_333 microtokens. 186 | -- daoDepositFees = 49_999 (20% of 249_999). 187 | -- affDepositFees = 74_999 (30% of 249_999). 188 | -- refDepositFees = 125_001 (the rest). 189 | refDepositFees, daoDepositFees, affDepositFees :: Integer 190 | refDepositFees = refillFees depositFeesDistribution 191 | daoDepositFees = daoFees depositFeesDistribution 192 | affDepositFees = affFees depositFeesDistribution 193 | 194 | -- depositFees = 249_999 with a fee of 0.75% over 33_333_333. 195 | depositFees = refDepositFees + daoDepositFees + affDepositFees 196 | 197 | userScript :: Value 198 | userScript = 199 | testUserNFT <> mainTokenValue (depositValue - depositFees) <> minAda 1 200 | 201 | stakingScript :: Value 202 | stakingScript = testStakingNFT <> mainTokenValue initialFounds <> minAda 1 203 | 204 | scriptValueOK :: Value -> Bool 205 | scriptValueOK val = val == userScript <> stakingScript 206 | 207 | adminWalletChangeValue :: Value 208 | adminWalletChangeValue = mainTokenValue (-initialFounds) 209 | <> minAda (-1) 210 | 211 | user1WalletChangeValue :: Value 212 | user1WalletChangeValue = mainTokenValue (-depositValue) 213 | <> minAda (-4) 214 | 215 | refWalletChangeValue :: Value 216 | refWalletChangeValue = mainTokenValue refDepositFees <> minAda 1 217 | 218 | daoWalletChangeValue :: Value 219 | daoWalletChangeValue = mainTokenValue daoDepositFees <> minAda 1 220 | 221 | affWalletChangeValue :: Value 222 | affWalletChangeValue = mainTokenValue affDepositFees <> minAda 1 223 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | -- Bump this if you need newer packages 2 | index-state: 2021-10-20T00:00:00Z 3 | 4 | packages: ./. 5 | 6 | -- We never, ever, want this. 7 | write-ghc-environment-files: never 8 | 9 | -- Always build tests and benchmarks. 10 | tests: true 11 | benchmarks: true 12 | 13 | -- The only sensible test display option 14 | test-show-details: streaming 15 | 16 | allow-newer: 17 | -- Copied from plutus-core 18 | size-based:template-haskell 19 | , ouroboros-consensus-byron:formatting 20 | , beam-core:aeson 21 | , beam-sqlite:aeson 22 | , beam-sqlite:dlist 23 | , beam-migrate:aeson 24 | 25 | -- Copied from plutus-core 26 | constraints: 27 | -- big breaking change here, inline-r doens't have an upper bound 28 | singletons < 3.0 29 | -- bizarre issue: in earlier versions they define their own 'GEq', in newer 30 | -- ones they reuse the one from 'some', but there isn't e.g. a proper version 31 | -- constraint from dependent-sum-template (which is the library we actually use). 32 | , dependent-sum > 0.6.2.0 33 | -- Newer Hashable have instances for Set, which breaks beam-migrate 34 | -- which declares its own instances of Hashable Set 35 | , hashable < 1.3.4.0 36 | 37 | -- These packages appear in our dependency tree and are very slow to build. 38 | -- Empirically, turning off optimization shaves off ~50% build time. 39 | -- It also mildly improves recompilation avoidance. 40 | -- For deve work we don't care about performance so much, so this is okay. 41 | package cardano-ledger-alonzo 42 | optimization: False 43 | package ouroboros-consensus-shelley 44 | optimization: False 45 | package ouroboros-consensus-cardano 46 | optimization: False 47 | package cardano-api 48 | optimization: False 49 | 50 | -- Copied from plutus-core 51 | source-repository-package 52 | type: git 53 | location: https://github.com/Quid2/flat.git 54 | tag: ee59880f47ab835dbd73bea0847dab7869fc20d8 55 | 56 | -- TODO replace with something more sustainable (and maintained) 57 | source-repository-package 58 | type: git 59 | location: https://github.com/input-output-hk/purescript-bridge.git 60 | tag: 366fc70b341e2633f3ad0158a577d52e1cd2b138 61 | 62 | source-repository-package 63 | type: git 64 | location: https://github.com/input-output-hk/servant-purescript.git 65 | tag: ebea59c7bdfc0338d83fca772b9a57e28560bcde 66 | 67 | -- Copied from plutus-core 68 | source-repository-package 69 | type: git 70 | location: https://github.com/input-output-hk/cardano-crypto.git 71 | tag: 07397f0e50da97eaa0575d93bee7ac4b2b2576ec 72 | 73 | -- Copied from plutus-core 74 | source-repository-package 75 | type: git 76 | location: https://github.com/input-output-hk/cardano-base 77 | tag: 4ea7e2d927c9a7f78ddc69738409a5827ab66b98 78 | subdir: 79 | base-deriving-via 80 | binary 81 | binary/test 82 | cardano-crypto-class 83 | cardano-crypto-praos 84 | cardano-crypto-tests 85 | measures 86 | orphans-deriving-via 87 | slotting 88 | strict-containers 89 | 90 | -- Copied from plutus-core 91 | source-repository-package 92 | type: git 93 | location: https://github.com/input-output-hk/cardano-prelude 94 | tag: fd773f7a58412131512b9f694ab95653ac430852 95 | subdir: 96 | cardano-prelude 97 | cardano-prelude-test 98 | 99 | source-repository-package 100 | type: git 101 | location: https://github.com/input-output-hk/cardano-addresses 102 | tag: d2f86caa085402a953920c6714a0de6a50b655ec 103 | subdir: 104 | core 105 | command-line 106 | 107 | source-repository-package 108 | type: git 109 | location: https://github.com/j-mueller/cardano-wallet 110 | tag: 6be73ab852c0592713dfe78218856d4a8a0ee69e 111 | subdir: 112 | lib/text-class 113 | lib/strict-non-empty-containers 114 | lib/core 115 | lib/test-utils 116 | lib/numeric 117 | lib/launcher 118 | lib/core-integration 119 | lib/cli 120 | lib/shelley 121 | 122 | source-repository-package 123 | type: git 124 | location: https://github.com/input-output-hk/ouroboros-network 125 | tag: 1f4973f36f689d6da75b5d351fb124d66ef1057d 126 | subdir: 127 | monoidal-synchronisation 128 | typed-protocols 129 | typed-protocols-cborg 130 | typed-protocols-examples 131 | ouroboros-network 132 | ouroboros-network-testing 133 | ouroboros-network-framework 134 | ouroboros-consensus 135 | ouroboros-consensus-byron 136 | ouroboros-consensus-cardano 137 | ouroboros-consensus-shelley 138 | io-sim 139 | io-classes 140 | network-mux 141 | ntp-client 142 | 143 | source-repository-package 144 | type: git 145 | location: https://github.com/input-output-hk/iohk-monitoring-framework 146 | -- Important Note: Read below, before changing this! 147 | tag: 46f994e216a1f8b36fe4669b47b2a7011b0e153c 148 | -- Are you thinking of updating this tag to some other commit? Please 149 | -- ensure that the commit you are about to use is the latest one from 150 | -- the *develop* branch of this repo: 151 | -- * 152 | -- (not master!) 153 | -- 154 | -- In particular we rely on the code from this PR: 155 | -- * 156 | -- being merged. 157 | subdir: 158 | iohk-monitoring 159 | tracer-transformers 160 | contra-tracer 161 | plugins/backend-aggregation 162 | plugins/backend-ekg 163 | plugins/backend-monitoring 164 | plugins/backend-trace-forwarder 165 | plugins/scribe-systemd 166 | 167 | source-repository-package 168 | type: git 169 | location: https://github.com/input-output-hk/cardano-ledger-specs 170 | tag: bf008ce028751cae9fb0b53c3bef20f07c06e333 171 | subdir: 172 | byron/ledger/impl 173 | cardano-ledger-core 174 | cardano-protocol-tpraos 175 | eras/alonzo/impl 176 | eras/byron/chain/executable-spec 177 | eras/byron/crypto 178 | eras/byron/crypto/test 179 | eras/byron/ledger/executable-spec 180 | eras/byron/ledger/impl/test 181 | eras/shelley/impl 182 | eras/shelley-ma/impl 183 | eras/shelley/chain-and-ledger/executable-spec 184 | eras/shelley/test-suite 185 | shelley/chain-and-ledger/shelley-spec-ledger-test 186 | libs/non-integral 187 | libs/small-steps 188 | libs/cardano-ledger-pretty 189 | semantics/small-steps-test 190 | 191 | -- A lot of plutus-apps dependencies have to be synchronized with the dependencies of 192 | -- cardano-node. If you update cardano-node, please make sure that all dependencies 193 | -- of cardano-node are also updated. 194 | source-repository-package 195 | type: git 196 | location: https://github.com/input-output-hk/cardano-node.git 197 | tag: b6ca519f97a0e795611a63174687e6bb70c9f752 198 | subdir: 199 | cardano-api 200 | cardano-node 201 | cardano-cli 202 | cardano-config 203 | 204 | source-repository-package 205 | type: git 206 | location: https://github.com/input-output-hk/optparse-applicative 207 | tag: 7497a29cb998721a9068d5725d49461f2bba0e7a 208 | 209 | source-repository-package 210 | type: git 211 | location: https://github.com/input-output-hk/Win32-network 212 | tag: 3825d3abf75f83f406c1f7161883c438dac7277d 213 | 214 | source-repository-package 215 | type: git 216 | location: https://github.com/input-output-hk/goblins 217 | tag: cde90a2b27f79187ca8310b6549331e59595e7ba 218 | 219 | -- A lot of plutus-apps dependencies have to be syncronized with the dependencies of 220 | -- plutus. If you update plutus, please make sure that all dependencies of plutus 221 | -- are also updated 222 | source-repository-package 223 | type: git 224 | location: https://github.com/input-output-hk/plutus 225 | tag: 3f089ccf0ca746b399c99afe51e063b0640af547 226 | subdir: 227 | plutus-core 228 | plutus-ledger-api 229 | plutus-tx 230 | plutus-tx-plugin 231 | word-array 232 | prettyprinter-configurable 233 | stubs/plutus-ghc-stub 234 | 235 | source-repository-package 236 | type: git 237 | location: https://github.com/input-output-hk/plutus-apps.git 238 | subdir: doc 239 | freer-extras 240 | playground-common 241 | plutus-chain-index 242 | plutus-chain-index-core 243 | plutus-contract 244 | plutus-ledger 245 | plutus-pab 246 | plutus-playground-server 247 | plutus-use-cases 248 | quickcheck-dynamic 249 | web-ghc 250 | tag: a6868cde87600051a4cc808777d665d0b859853c 251 | -------------------------------------------------------------------------------- /src/Staking/Business/User.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE NumericUnderscores #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | {-| 6 | Module : Staking.Business.User 7 | Description : Business logic related to the main operations that a user can 8 | perform. 9 | Copyright : P2P Solutions Ltd. 10 | License : GPL-3 11 | Maintainer : laurynas@adafinance.io 12 | Stability : develop 13 | -} 14 | 15 | module Staking.Business.User 16 | ( claim 17 | , compound 18 | , deposit 19 | , withdraw 20 | , depositFees 21 | , withdrawFees 22 | , isAfter 23 | , days 24 | , depositLevel 25 | , computeRewards) where 26 | 27 | -- Third-party libraries. 28 | import Ledger 29 | import PlutusTx.Prelude 30 | 31 | -- Internal modules. 32 | import Staking.Business.Types 33 | 34 | {-| If the amount to deposit is greater or equal than the minimum amount setted, 35 | then, this function computes the update of the UserState by adding a new 36 | element on the deposit's list and its FeesDistribution. 37 | * This element is a tuple with the amount given by the parameters is 38 | subtracted by the fees and the POSIXTime of the operation. 39 | * The fees are calculated using the fixed percentage set for this 40 | operation and the amount being deposited. 41 | 42 | Other way it returns Nothing. 43 | -} 44 | {-# INLINABLE deposit #-} 45 | deposit 46 | :: UserState 47 | -> Integer 48 | -> POSIXTime 49 | -> OperationSettings 50 | -> Maybe (UserState, FeesDistribution) 51 | deposit userState amount cTime fconf = 52 | if amount < minDeposit fconf 53 | then Nothing 54 | else Just (addDeposit userState cTime (amount - totalFees), fees) 55 | where 56 | fees :: FeesDistribution 57 | fees = depositFees amount fconf 58 | 59 | refFees, daoFees, affFees :: Integer 60 | FeesDistribution refFees daoFees affFees = fees 61 | 62 | totalFees :: Integer 63 | totalFees = refFees + daoFees + affFees 64 | 65 | {-| If the amount to withdraw is between the minimum amount setted and the total 66 | amount deposited, then this function computes the update of the UserState by 67 | removing or updating the elements on the deposit's list and its 68 | FeesDistribution. 69 | * An element is updated when the value being withdrawn is lower than it's 70 | value and removed if tht's not the case. 71 | 72 | Other way it returns Nothing. 73 | -} 74 | {-# INLINABLE withdraw #-} 75 | withdraw 76 | :: UserState 77 | -> Integer 78 | -> OperationSettings 79 | -> Maybe (UserState, FeesDistribution) 80 | withdraw userState amount fconf = 81 | if amount < minWithdraw fconf || amount > totalAmount 82 | then Nothing 83 | else Just (newUserState, withdrawFees amount fconf) 84 | where 85 | totalAmount :: Integer 86 | totalAmount = sum $ map amountDeposit oDeposits 87 | 88 | newUserState :: UserState 89 | newUserState = userState { deposits = withdrawTx oDeposits amount } 90 | 91 | oDeposits :: [Deposit] 92 | oDeposits = deposits userState 93 | 94 | {-| If the amount to claim is greater or equal than the minimum amount setted, 95 | then, this function computes the new UserState by updating his last claim 96 | and, the total amount of rewards to be claimed. 97 | 98 | Other way it returns Nothing. 99 | -} 100 | {-# INLINABLE claim #-} 101 | claim 102 | :: UserState 103 | -> POSIXTime 104 | -> OperationSettings 105 | -> Maybe (UserState, Integer) 106 | claim userState cTime fconf = 107 | if rewards < minClaim fconf 108 | then Nothing 109 | else Just (newUserState, rewards) 110 | where 111 | newUserState :: UserState 112 | newUserState = userState { lastClaim = Just cTime} 113 | 114 | rewards :: Integer 115 | rewards = computeRewards (deposits userState) (lastClaim userState) cTime 116 | 117 | -- | This function calls claim and deposit the total amount of rewards. 118 | {-# INLINABLE compound #-} 119 | compound 120 | :: UserState 121 | -> POSIXTime 122 | -> OperationSettings 123 | -> Maybe (UserState, Integer) 124 | compound userState cTime fconf = 125 | claim userState cTime fconf >>= 126 | \(userState', rews) -> Just (addDeposit userState' cTime rews, rews) 127 | 128 | {-| This function recursively subtracts the required amount from the last 129 | deposit, deleting its record if its entire amount has already been 130 | subtracted. -} 131 | {-# INLINABLE withdrawTx #-} 132 | withdrawTx :: [Deposit] -> Integer -> [Deposit] 133 | withdrawTx (lastDep : dep) amount = 134 | if amountDeposited > amount 135 | then (timeDeposit lastDep, amountDeposited - amount) : dep 136 | else withdrawTx dep (amount - amountDeposited) 137 | where 138 | amountDeposited :: Integer 139 | amountDeposited = amountDeposit lastDep 140 | 141 | withdrawTx [] _ = [] 142 | 143 | {-# INLINABLE addDeposit #-} 144 | addDeposit :: UserState -> POSIXTime -> Integer -> UserState 145 | addDeposit userState cTime amount = 146 | userState { deposits = (cTime, amount) : deposits userState } 147 | 148 | {- | computeFees takes: 149 | * the function to get the fee value (i.e., the amount charged as fees 150 | when a user performs either a deposit or a withdraw action), 151 | * the amount with respect to which the fees are calculated. 152 | * the settings necessary to calculate the transaction, 153 | * return the percentage of the fees destined to each wallet 154 | 155 | If there are any rounding issues, it is the incentives pool that is 156 | favored - that is, the first coordinate of the result.-} 157 | {-# INLINABLE computeFees #-} 158 | computeFees :: 159 | (OperationSettings -> Integer) 160 | -> Integer 161 | -> OperationSettings 162 | -> FeesDistribution 163 | computeFees transactionFee amount fconf = 164 | FeesDistribution { refillFees = refFees 165 | , daoFees = dFees 166 | , affFees = aFees 167 | } 168 | where 169 | refFees :: Integer 170 | refFees = totalFees - dFees - aFees 171 | 172 | dFees :: Integer 173 | dFees = divide (totalFees * daoShare fconf) 1_000_000 174 | 175 | aFees :: Integer 176 | aFees = divide (totalFees * affShare fconf) 1_000_000 177 | 178 | totalFees :: Integer 179 | totalFees = divide (amount * transactionFee fconf) 1_000_000 180 | 181 | {-# INLINABLE withdrawFees #-} 182 | withdrawFees :: Integer -> OperationSettings -> FeesDistribution 183 | withdrawFees = computeFees withdrawFee 184 | 185 | {-# INLINABLE depositFees #-} 186 | depositFees :: Integer -> OperationSettings -> FeesDistribution 187 | depositFees = computeFees depositFee 188 | 189 | -- Check that `now` happens after all POSIXTime values in UserState. 190 | {-# INLINABLE isAfter #-} 191 | isAfter :: POSIXTime -> UserState -> Bool 192 | isAfter now UserState{..} = 193 | all ((now >) . timeDeposit) deposits 194 | && case lastClaim of 195 | Nothing -> True 196 | Just lc -> now > lc 197 | 198 | 199 | -- miliseconds per day 200 | {-# INLINABLE msPerDay #-} 201 | msPerDay :: Integer 202 | msPerDay = 1000 * 60 * 60 * 24 203 | 204 | -- miliseconds per year 205 | {-# INLINABLE msPerYear #-} 206 | msPerYear :: Integer 207 | msPerYear = msPerDay * 365 208 | 209 | -- day number to POSIXTime 210 | {-# INLINABLE days #-} 211 | days :: Integer -> POSIXTime 212 | days n = POSIXTime (n * msPerDay) 213 | 214 | {-# INLINABLE levelAPR #-} 215 | levelAPR :: Integer -> Integer 216 | levelAPR n | n == 1 = 150_000 217 | | n == 2 = 200_000 218 | 219 | {-# INLINABLE depositLevel #-} 220 | depositLevel :: POSIXTime -> POSIXTime -> Integer 221 | depositLevel depositTime now = 222 | if (now - depositTime) < days 90 223 | then 1 224 | else 2 225 | 226 | {-# INLINABLE rewardsPerDeposit #-} 227 | rewardsPerDeposit 228 | :: Maybe POSIXTime 229 | -> POSIXTime 230 | -> Deposit 231 | -> Integer 232 | rewardsPerDeposit lastClaim now (depTime, amount) = 233 | case lastClaim of 234 | Nothing -> getRewards $ getPOSIXTime (now - depTime) 235 | Just lClaim -> 236 | if lClaim < depTime 237 | then getRewards $ getPOSIXTime (now - depTime) 238 | else getRewards $ getPOSIXTime (now - lClaim) 239 | where 240 | getRewards :: Integer -> Integer 241 | getRewards duration = (getLevel * duration * amount) `divide` msPerYearMi 242 | 243 | msPerYearMi :: Integer 244 | msPerYearMi = msPerYear * 1_000_000 245 | 246 | getLevel :: Integer 247 | getLevel = levelAPR $ depositLevel depTime now 248 | 249 | {-# INLINABLE computeRewards #-} 250 | computeRewards 251 | :: [Deposit] 252 | -> Maybe POSIXTime 253 | -> POSIXTime 254 | -> Integer 255 | computeRewards deposits lastClaim now = 256 | foldr getRewards 0 deposits 257 | where 258 | getRewards :: Deposit -> Integer -> Integer 259 | getRewards dep rews = rews + rewardsPerDeposit lastClaim now dep 260 | -------------------------------------------------------------------------------- /test/Tests/Attacks/Deposit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeOperators#-} 7 | 8 | {-| 9 | Module : Tests.Attacks.Deposit 10 | Description : A new off-chain code to test an attack the deposit validator. 11 | Copyright : P2P Solutions Ltd. 12 | License : GPL-3 13 | Maintainer : laurynas@adafinance.io 14 | Stability : develop 15 | -} 16 | 17 | module Tests.Attacks.Deposit 18 | ( AttackSchema 19 | -- ^ Endpoints 20 | , attackUserEndpoints 21 | ) where 22 | 23 | import Control.Monad 24 | import Data.Monoid (Last (..)) 25 | import Data.Text as T (Text) 26 | 27 | -- Third-party libraries libraries. 28 | import Ledger hiding (singleton) 29 | import Ledger.Constraints as Constraints 30 | import Plutus.Contract as Contract 31 | import PlutusTx 32 | 33 | -- Internal modules. 34 | import MainToken 35 | import Staking.Business 36 | import Staking.Types 37 | import Utils.OffChain 38 | import Tests.Attacks.AttackUtils 39 | import Tests.TestUtils 40 | 41 | -- Schema. 42 | type AttackSchema = 43 | Endpoint "depositNegativeAttack" MainToken 44 | .\/ Endpoint "depositEmptyListAttack" MainToken 45 | .\/ Endpoint "depositWithoutFeesAttack" MainToken 46 | 47 | attackUserEndpoints :: Staking -> Contract (Last Staking) AttackSchema Text () 48 | attackUserEndpoints staking = forever 49 | $ handleError logError 50 | $ awaitPromise 51 | $ depositNegativeEndpoint 52 | `select` depositEmptyListEndpoint 53 | `select` depositWithoutFeesEndpoint 54 | where 55 | depositNegativeEndpoint :: Promise (Last Staking) AttackSchema Text () 56 | depositNegativeEndpoint = 57 | endpoint @"depositNegativeAttack" $ depositNegativeAttack staking 58 | 59 | depositEmptyListEndpoint :: Promise (Last Staking) AttackSchema Text () 60 | depositEmptyListEndpoint = 61 | endpoint @"depositEmptyListAttack" $ depositEmptyListAttack staking 62 | 63 | depositWithoutFeesEndpoint :: Promise (Last Staking) AttackSchema Text () 64 | depositWithoutFeesEndpoint = 65 | endpoint @"depositWithoutFeesAttack" $ depositWithoutFeesAttack staking 66 | 67 | 68 | -- Off-chain code. 69 | depositNegativeAttack :: forall w s. Staking -> MainToken -> Contract w s Text () 70 | depositNegativeAttack staking@Staking{..} am@(MicroToken amount) = do 71 | cTime <- currentTime 72 | ownPKH <- Contract.ownPubKeyHash 73 | (orefUser, oUser) <- findUserUTxO staking ownPKH 74 | oldUserState <- getUserState oUser 75 | 76 | let depositRes = deposit oldUserState (getMicroToken am) 77 | cTime (opSettings settings) 78 | 79 | case depositRes of 80 | Nothing -> logInfo @String $ 81 | "Intended amount is lower than minimum allowed for deposits." 82 | Just (newUserState,feesD) -> do 83 | let refFees = refillFees feesD 84 | dFees = daoFees feesD 85 | aFees = affFees feesD 86 | 87 | oldUserVal = getChainIndexTxOutValue oUser 88 | totalFees = refFees + dFees + aFees 89 | deposited = getMicroToken am - totalFees 90 | newUserVal = oldUserVal <> mainTokenValue deposited 91 | newUserDatum = UserDatum newUserState 92 | 93 | range = interval cTime (cTime + validTimeRange) 94 | red = Redeemer $ PlutusTx.toBuiltinData 95 | $ Deposit (MicroToken (-amount)) cTime 96 | lookups = mkLookups staking [ (orefUser, oUser) ] 97 | tx = Constraints.mustSpendScriptOutput orefUser red 98 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 99 | <> Constraints.mustValidateIn range 100 | <> Constraints.mustPayToPubKey 101 | (refWallet settings) (mainTokenValue refFees <> minAda 1) 102 | <> Constraints.mustPayToPubKey 103 | (daoWallet settings) (mainTokenValue dFees <> minAda 1) 104 | <> Constraints.mustPayToPubKey 105 | (affWallet settings) (mainTokenValue aFees <> minAda 1) 106 | 107 | submittedTx <- submitTxConstraintsWith lookups tx 108 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 109 | logInfo @String $ "User deposited " ++ show (MicroToken (-amount)) ++ 110 | " micro MyToken to their " ++ 111 | "script UTxO, and paid " ++ show totalFees ++ 112 | " micro MyToken in fees." 113 | 114 | depositEmptyListAttack 115 | :: forall w s. Staking 116 | -> MainToken 117 | -> Contract w s Text () 118 | depositEmptyListAttack staking@Staking{..} am = do 119 | cTime <- currentTime 120 | ownPKH <- Contract.ownPubKeyHash 121 | (orefUser, oUser) <- findUserUTxO staking ownPKH 122 | oldUserState <- getUserState oUser 123 | 124 | let depositRes = deposit oldUserState (getMicroToken am) 125 | cTime (opSettings settings) 126 | 127 | case depositRes of 128 | Nothing -> logInfo @String $ 129 | "Intended amount is lower than minimum allowed for deposits." 130 | Just (newUserState,feesD) -> do 131 | let refFees = refillFees feesD 132 | dFees = daoFees feesD 133 | aFees = affFees feesD 134 | 135 | oldUserVal = getChainIndexTxOutValue oUser 136 | totalFees = refFees + dFees + aFees 137 | deposited = getMicroToken am - totalFees 138 | newUserVal = oldUserVal <> mainTokenValue deposited 139 | negativeUserState = newUserState { deposits = [] } 140 | newUserDatum = UserDatum negativeUserState 141 | 142 | range = interval cTime (cTime + validTimeRange) 143 | red = Redeemer $ PlutusTx.toBuiltinData 144 | $ Deposit am cTime 145 | lookups = mkLookups staking [ (orefUser, oUser) ] 146 | tx = Constraints.mustSpendScriptOutput orefUser red 147 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 148 | <> Constraints.mustValidateIn range 149 | <> Constraints.mustPayToPubKey 150 | (refWallet settings) (mainTokenValue refFees <> minAda 1) 151 | <> Constraints.mustPayToPubKey 152 | (daoWallet settings) (mainTokenValue dFees <> minAda 1) 153 | <> Constraints.mustPayToPubKey 154 | (affWallet settings) (mainTokenValue aFees <> minAda 1) 155 | 156 | submittedTx <- submitTxConstraintsWith lookups tx 157 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 158 | logInfo @String $ "User had their script UTxO deposits emptied" 159 | 160 | depositWithoutFeesAttack 161 | :: forall w s. Staking 162 | -> MainToken 163 | -> Contract w s Text () 164 | depositWithoutFeesAttack staking@Staking{..} am = do 165 | cTime <- currentTime 166 | ownPKH <- Contract.ownPubKeyHash 167 | (orefUser, oUser) <- findUserUTxO staking ownPKH 168 | oldUserState <- getUserState oUser 169 | 170 | let depositRes = deposit oldUserState (getMicroToken am) 171 | cTime (opSettings settings) 172 | 173 | case depositRes of 174 | Nothing -> logInfo @String $ 175 | "Intended amount is lower than minimum allowed for deposits." 176 | Just (newUserState, _) -> do 177 | let oldUserVal = getChainIndexTxOutValue oUser 178 | deposited = getMicroToken am 179 | newUserVal = oldUserVal <> mainTokenValue deposited 180 | newUserDatum = UserDatum newUserState 181 | 182 | range = interval cTime (cTime + validTimeRange) 183 | red = Redeemer $ PlutusTx.toBuiltinData 184 | $ Deposit am cTime 185 | lookups = mkLookups staking [ (orefUser, oUser) ] 186 | tx = Constraints.mustSpendScriptOutput orefUser red 187 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 188 | <> Constraints.mustValidateIn range 189 | 190 | submittedTx <- submitTxConstraintsWith lookups tx 191 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 192 | logInfo @String $ "User deposited " ++ show am ++ " micro " ++ 193 | "MyToken to their script UTxO without fees." 194 | -------------------------------------------------------------------------------- /test/Tests/Attacks/Withdraw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeOperators#-} 7 | 8 | {-| 9 | Module : Tests.Attacks.Withdraw 10 | Description : A new off-chain code to test an attack the withdraw validator. 11 | Copyright : P2P Solutions Ltd. 12 | License : GPL-3 13 | Maintainer : laurynas@adafinance.io 14 | Stability : develop 15 | -} 16 | 17 | module Tests.Attacks.Withdraw 18 | ( AttackSchema 19 | -- ^ Endpoints 20 | , attackUserEndpoints 21 | ) where 22 | 23 | import Control.Monad 24 | import Data.Monoid (Last (..)) 25 | import Data.Text as T (Text) 26 | 27 | -- Third-party libraries libraries. 28 | import Ledger hiding (singleton) 29 | import Ledger.Constraints as Constraints 30 | import Plutus.Contract as Contract 31 | import PlutusTx 32 | 33 | -- Internal modules. 34 | import Staking.Business 35 | import Staking.Types 36 | import MainToken 37 | import Utils.OffChain 38 | import Tests.Attacks.AttackUtils 39 | import Tests.TestUtils 40 | 41 | -- Schema. 42 | type AttackSchema = 43 | Endpoint "withdrawAttack" MainToken 44 | .\/ Endpoint "fakeWithdrawAttack" MainToken 45 | .\/ Endpoint "withdrawWithoutFeesAttack" MainToken 46 | 47 | attackUserEndpoints :: Staking -> Contract (Last Staking) AttackSchema Text () 48 | attackUserEndpoints staking = forever 49 | $ handleError logError 50 | $ awaitPromise 51 | $ withdrawAttackEndpoint 52 | `select` fakeWithdrawEndpoint 53 | `select` withdrawWithoutFeesEndpoint 54 | where 55 | withdrawAttackEndpoint :: Promise (Last Staking) AttackSchema Text () 56 | withdrawAttackEndpoint = 57 | endpoint @"withdrawAttack" $ withdrawAttack staking 58 | 59 | fakeWithdrawEndpoint :: Promise (Last Staking) AttackSchema Text () 60 | fakeWithdrawEndpoint = 61 | endpoint @"fakeWithdrawAttack" $ fakeWithdrawAttack staking 62 | 63 | withdrawWithoutFeesEndpoint :: Promise (Last Staking) AttackSchema Text () 64 | withdrawWithoutFeesEndpoint = 65 | endpoint @"withdrawWithoutFeesAttack" $ withdrawWithoutFeesAttack staking 66 | 67 | 68 | -- Off-chain code. 69 | withdrawAttack :: forall w s. Staking -> MainToken -> Contract w s Text () 70 | withdrawAttack staking@Staking{..} am = do 71 | cTime <- currentTime 72 | ownPKH <- Contract.ownPubKeyHash 73 | (orefUser, oUser) <- findUserUTxO staking ownPKH 74 | oldUserState <- getUserState oUser 75 | 76 | let withdrawRes = withdraw oldUserState (getMicroToken am) 77 | (opSettings settings) 78 | case withdrawRes of 79 | Nothing -> logInfo @String $ 80 | "Intended amount is lower than minimum allowed for withdrawals." 81 | Just (newUserState, feesW) -> do 82 | let refFees = refillFees feesW 83 | dFees = daoFees feesW 84 | aFees = affFees feesW 85 | 86 | oldUserVal = getChainIndexTxOutValue oUser 87 | newUserVal = oldUserVal 88 | <> mainTokenValue (-getMicroToken am `div` 2) 89 | newUserDatum = UserDatum newUserState 90 | range = interval cTime (cTime + validTimeRange) 91 | red = Redeemer 92 | $ PlutusTx.toBuiltinData 93 | $ Withdraw am cTime 94 | lookups = mkLookups staking [ (orefUser, oUser) ] 95 | tx = Constraints.mustSpendScriptOutput orefUser red 96 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 97 | <> Constraints.mustValidateIn range 98 | <> Constraints.mustPayToPubKey 99 | (refWallet settings) (mainTokenValue refFees <> minAda 1) 100 | <> Constraints.mustPayToPubKey 101 | (daoWallet settings) (mainTokenValue dFees <> minAda 1) 102 | <> Constraints.mustPayToPubKey 103 | (affWallet settings) (mainTokenValue aFees <> minAda 1) 104 | <> Constraints.mustPayToPubKey 105 | ownPKH 106 | (mainTokenValue (getMicroToken am `div` 2) <> minAda 1) 107 | 108 | submittedTx <- submitTxConstraintsWith lookups tx 109 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 110 | logInfo @String $ "User withdraw " ++ 111 | show (getMicroToken am `div` 2) ++ 112 | " micro MyToken from " ++ 113 | "their script UTxO, and paid " ++ 114 | show (refFees + dFees + aFees) ++ 115 | " micro MyToken in fees." 116 | 117 | fakeWithdrawAttack :: forall w s. Staking -> MainToken -> Contract w s Text () 118 | fakeWithdrawAttack staking@Staking{..} am = do 119 | cTime <- currentTime 120 | ownPKH <- Contract.ownPubKeyHash 121 | (orefUser, oUser) <- findUserUTxO staking ownPKH 122 | oldUserState <- getUserState oUser 123 | 124 | let withdrawRes = withdraw oldUserState (getMicroToken am) 125 | (opSettings settings) 126 | case withdrawRes of 127 | Nothing -> logInfo @String $ 128 | "Intended amount is lower than minimum allowed for withdrawals." 129 | Just (_, feesW) -> do 130 | let refFees = refillFees feesW 131 | dFees = daoFees feesW 132 | aFees = affFees feesW 133 | 134 | oldUserVal = getChainIndexTxOutValue oUser 135 | newUserVal = oldUserVal <> mainTokenValue (-getMicroToken am) 136 | newUserDatum = UserDatum oldUserState -- State without withdraw 137 | range = interval cTime (cTime + validTimeRange) 138 | red = Redeemer 139 | $ PlutusTx.toBuiltinData 140 | $ Withdraw am cTime 141 | lookups = mkLookups staking [ (orefUser, oUser) ] 142 | tx = Constraints.mustSpendScriptOutput orefUser red 143 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 144 | <> Constraints.mustValidateIn range 145 | <> Constraints.mustPayToPubKey 146 | (refWallet settings) (mainTokenValue refFees <> minAda 1) 147 | <> Constraints.mustPayToPubKey 148 | (daoWallet settings) (mainTokenValue dFees <> minAda 1) 149 | <> Constraints.mustPayToPubKey 150 | (affWallet settings) (mainTokenValue aFees <> minAda 1) 151 | <> Constraints.mustPayToPubKey 152 | ownPKH (mainTokenValue (getMicroToken am) <> minAda 1) 153 | 154 | submittedTx <- submitTxConstraintsWith lookups tx 155 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 156 | logInfo @String $ "User withdraw " ++ show am ++ 157 | " micro MyToken from " ++ 158 | "their script UTxO, and paid " ++ 159 | show (refFees + dFees + aFees) ++ 160 | " micro MyToken in fees." 161 | 162 | withdrawWithoutFeesAttack 163 | :: forall w s. Staking 164 | -> MainToken 165 | -> Contract w s Text () 166 | withdrawWithoutFeesAttack staking@Staking{..} am = do 167 | cTime <- currentTime 168 | ownPKH <- Contract.ownPubKeyHash 169 | (orefUser, oUser) <- findUserUTxO staking ownPKH 170 | oldUserState <- getUserState oUser 171 | 172 | let withdrawRes = withdraw oldUserState (getMicroToken am) 173 | (opSettings settings) 174 | case withdrawRes of 175 | Nothing -> logInfo @String $ 176 | "Intended amount is lower than minimum allowed for withdrawals." 177 | Just (newUserState, _) -> do 178 | let oldUserVal = getChainIndexTxOutValue oUser 179 | newUserVal = oldUserVal <> mainTokenValue (-getMicroToken am) 180 | newUserDatum = UserDatum newUserState 181 | range = interval cTime (cTime + validTimeRange) 182 | red = Redeemer 183 | $ PlutusTx.toBuiltinData $ Withdraw am cTime 184 | lookups = mkLookups staking [ (orefUser, oUser) ] 185 | tx = Constraints.mustSpendScriptOutput orefUser red 186 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 187 | <> Constraints.mustValidateIn range 188 | <> Constraints.mustPayToPubKey 189 | ownPKH (mainTokenValue (getMicroToken am) <> minAda 1) 190 | 191 | submittedTx <- submitTxConstraintsWith lookups tx 192 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 193 | logInfo @String $ "User withdraw " ++ show am ++ " micro " ++ 194 | "MyToken to their script UTxO without fees." 195 | -------------------------------------------------------------------------------- /test/BCExplorer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# LANGUAGE NumericUnderscores #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE LambdaCase #-} 12 | {-# LANGUAGE TupleSections #-} 13 | {-# LANGUAGE ExistentialQuantification #-} 14 | 15 | module BCExplorer where 16 | 17 | {-| 18 | Module : BCExplorer 19 | Description : Blockchain explorer for traces. 20 | Copyright : P2P Solutions Ltd. 21 | License : GPL-3 22 | Maintainer : laurynas@adafinance.io 23 | Stability : develop 24 | -} 25 | 26 | import qualified Prelude as HP 27 | import System.IO (Handle, hPutStrLn) 28 | import System.Console.ANSI 29 | 30 | import Control.Lens hiding (index, under) 31 | import Control.Monad hiding (fmap) 32 | import Control.Monad.Freer 33 | import Control.Monad.Freer.Extras.Log 34 | import Control.Monad.Freer.TH (makeEffect) 35 | import Control.Monad.IO.Class (MonadIO (..)) 36 | 37 | import Data.Default 38 | import qualified Data.Set as Set 39 | import qualified Data.Map as Map 40 | import Data.Maybe ( fromJust ) 41 | 42 | import Ledger 43 | import Ledger.Value as Value 44 | import Plutus.Trace.Emulator ( chainNewestFirst 45 | , EmulatorTrace 46 | , TraceConfig 47 | , EmulatorConfig 48 | ) 49 | import qualified Plutus.Trace.Emulator as Emulator 50 | import qualified Plutus.PAB.Simulator as Simulator 51 | 52 | import PlutusTx.Prelude hiding (Semigroup(..), unless) 53 | import Prelude (Semigroup(..)) 54 | import Wallet.Emulator.Wallet 55 | import Wallet.Emulator.MultiAgent ( EmulatorState (..) 56 | , _eteEmulatorTime 57 | , _eteEvent 58 | ) 59 | 60 | import Plutus.V1.Ledger.Api 61 | import Ledger.TimeSlot 62 | 63 | data FromDataFunc = forall a. (ToData a, HP.Show a) => FD (Data -> Maybe a) 64 | 65 | makeEffect ''Emulator.PrintEffect 66 | 67 | traceNFTFD :: [FromDataFunc] -> AssetClass -> Simulator.Simulation t () 68 | traceNFTFD fds nft = Simulator.blockchain >>= findPrintLastTx 69 | where 70 | findPrintLastTx :: Blockchain -> Simulator.Simulation t () 71 | findPrintLastTx bss = Control.Monad.mapM_ (pp bss) $ HP.reverse bss 72 | 73 | pp :: Blockchain -> [OnChainTx] -> Simulator.Simulation t () 74 | pp bss ontxs = case filter nftTx ontxs of 75 | [] -> return () 76 | bs -> liftIO $ HP.putStrLn $ printTxs fds bss bs 77 | 78 | nftTx :: OnChainTx -> Bool 79 | nftTx = any (checkTxHasNFT nft) . txOutputs . getTx 80 | 81 | checkTxHasNFT :: AssetClass -> TxOut -> Bool 82 | checkTxHasNFT asc o = assetClassValueOf (txOutValue o) asc == 1 83 | 84 | printPABLastTx :: Simulator.Simulation t () 85 | printPABLastTx = printPABLastTxFD [] 86 | 87 | printPABLastTxFD :: [FromDataFunc] -> Simulator.Simulation t () 88 | printPABLastTxFD fds = Simulator.blockchain >>= findPrintLastTx 89 | where 90 | findPrintLastTx :: Blockchain -> Simulator.Simulation t () 91 | findPrintLastTx [] = return () 92 | findPrintLastTx ([]:bss) = findPrintLastTx bss 93 | findPrintLastTx (bs:bss) = liftIO $ HP.putStrLn $ printTxs fds bss $ 94 | take 1 bs 95 | 96 | printPABLastTxAtSlot :: Integer -> Simulator.Simulation t () 97 | printPABLastTxAtSlot n = Simulator.blockchain >>= findPrintLastTx 98 | where 99 | findPrintLastTx :: Blockchain -> Simulator.Simulation t () 100 | findPrintLastTx bss | n < length bss = 101 | liftIO $ HP.putStrLn $ 102 | printTxs [] bss $ 103 | take 1 (bss !! (length bss HP.- n HP.- 1)) 104 | | otherwise = return () 105 | 106 | printBlockChainCFD :: [FromDataFunc] -> Emulator.EmulatorTrace () 107 | printBlockChainCFD fds = Emulator.chainState >>= \chain -> do 108 | case chain ^. chainNewestFirst of 109 | [] -> return () 110 | bss -> Control.Monad.mapM_ (logInfo @HP.String . printTxs fds bss) $ 111 | HP.reverse bss 112 | 113 | printLastTx :: Emulator.EmulatorTrace () 114 | printLastTx = printLastTxFD [] 115 | 116 | printLastTxFD :: [FromDataFunc] -> Emulator.EmulatorTrace () 117 | printLastTxFD fds = Emulator.chainState >>= \chain -> do 118 | case chain ^. chainNewestFirst of 119 | [] -> return () 120 | (bs : bss) -> logInfo @HP.String $ printTxs fds bss bs 121 | 122 | lookUpUnspendOut :: Blockchain -> TxOutRef -> Maybe (Tx, TxOut) 123 | lookUpUnspendOut bss oref = 124 | case concatMap (mapMaybe (lkOutTx . getTx)) bss of 125 | [o] -> Just o 126 | _ -> Nothing 127 | where 128 | lkOutTx :: Tx -> Maybe (Tx, TxOut) 129 | lkOutTx tx = (tx,) <$> Map.lookup oref (unspentOutputsTx tx) 130 | 131 | getTx :: OnChainTx -> Tx 132 | getTx (Invalid tx) = tx 133 | getTx (Valid tx) = tx 134 | 135 | printTxs :: [FromDataFunc] -> Blockchain -> [OnChainTx] -> HP.String 136 | printTxs fds bss = HP.unlines . map (printTx fds bss) 137 | 138 | printTx :: [FromDataFunc] -> Blockchain -> OnChainTx -> HP.String 139 | printTx fds bss ontx = 140 | HP.unlines [ "" 141 | , txType 142 | , HP.unwords 143 | [ under $ bold "POSIXTime range:" 144 | , HP.show (slotRangeToPOSIXTimeRange def $ txValidRange tx) 145 | ] 146 | , HP.unwords 147 | [ under $ bold "Slot range:" 148 | , HP.show (txValidRange tx) 149 | ] 150 | , "┏━" ++ bold " Inputs " ++ HP.replicate 80 '━' 151 | , HP.unlines (map (printInput fds bss) inps) 152 | , "┏━" ++ bold " Outputs " ++ HP.replicate 80 '━' 153 | , HP.unlines (map (printOut fds tx) outs) 154 | ] 155 | where 156 | tx = getTx ontx 157 | txType = case ontx of 158 | Valid _ -> bold "Valid Transaction" 159 | Invalid _ -> bold "Invalid Transaction" 160 | inps = Set.toList $ txInputs tx 161 | outs = zip [0..] $ txOutputs tx 162 | 163 | printInput :: [FromDataFunc] -> Blockchain -> TxIn -> HP.String 164 | printInput fds bss txin = 165 | HP.unlines $ map ("┃ " ++) 166 | [ bold "<< In" 167 | , HP.unwords [under "UTxORef", "|", HP.show $ txInRef txin] 168 | , HP.unwords [under "Type", " |", ppTxInType $ txInType txin] 169 | , HP.unwords [under "Value", " |", v] 170 | , HP.unwords [under "Datum", " |", ppDatum md] 171 | , bold ">>" 172 | ] 173 | where 174 | ppTxInType :: Maybe TxInType -> HP.String 175 | ppTxInType Nothing = "Nothing" 176 | ppTxInType (Just (ConsumeScriptAddress csv csr csd)) = 177 | HP.unwords [ "ConsumeScriptAddress" 178 | , HP.show csv 179 | , HP.show csr 180 | , ppDatum $ Just csd 181 | ] 182 | ppTxInType (Just ConsumePublicKeyAddress) = "ConsumePublicKeyAddress" 183 | 184 | txout :: Maybe (Tx, TxOut) 185 | txout = lookUpUnspendOut bss $ txInRef txin 186 | 187 | v :: HP.String 188 | v = maybe "" (HP.show . txOutValue . snd) txout 189 | 190 | ppDatum :: Maybe Datum -> HP.String 191 | ppDatum md' = 192 | case (md', find (\(FD f) -> isJust $ f $ 193 | toData $ getDatum (fromJust md')) fds) of 194 | (Nothing, _) -> "Nothing" 195 | (Just d', Nothing) -> HP.show d' 196 | (Just d', Just (FD f)) -> HP.show $ f $ toData $ getDatum d' 197 | 198 | md :: Maybe Datum 199 | md = txout >>= \(tx, o) -> txOutDatumHash o >>= flip Map.lookup (txData tx) 200 | 201 | printOut :: [FromDataFunc] -> Tx -> (Integer,TxOut) -> HP.String 202 | printOut fds tx (idx,txout) = 203 | HP.unlines $ map ("┃ " ++) 204 | [ bold "<< Out" 205 | , HP.unwords [under "UTxORef", "|", HP.show $ TxOutRef (txId tx) idx] 206 | , HP.unwords [under "Address", "|", addr] 207 | , HP.unwords [under "Value", " |", v] 208 | , HP.unwords [under "Datum", " |", d] 209 | , bold ">>" 210 | ] 211 | where 212 | addr :: HP.String 213 | addr = HP.show $ txOutAddress txout 214 | v :: HP.String 215 | v = HP.show $ txOutValue txout 216 | 217 | d :: HP.String 218 | d = case (md, find (\(FD f) -> isJust $ f $ 219 | toData $ getDatum (fromJust md)) fds) of 220 | (Nothing, _) -> "Nothing" 221 | (Just d', Nothing) -> HP.show d' 222 | (Just d', Just (FD f)) -> HP.show $ f $ toData $ getDatum d' 223 | 224 | md :: Maybe Datum 225 | md = txOutDatumHash txout >>= flip Map.lookup (txData tx) 226 | 227 | bold :: HP.String -> HP.String 228 | bold str = setSGRCode [SetConsoleIntensity BoldIntensity] 229 | ++ 230 | str 231 | ++ 232 | setSGRCode [SetConsoleIntensity NormalIntensity] 233 | 234 | under :: HP.String -> HP.String 235 | under str = setSGRCode [SetUnderlining SingleUnderline] 236 | ++ 237 | str 238 | ++ 239 | setSGRCode [SetUnderlining NoUnderline] 240 | 241 | color :: Color -> Emulator.EmulatorTrace a -> Emulator.EmulatorTrace a 242 | color c m = do 243 | logError @HP.String $ setSGRCode [SetColor Foreground Vivid c] 244 | a <- m 245 | logError @HP.String $ setSGRCode [SetColor Foreground Vivid White] 246 | return a 247 | 248 | pad :: HP.Int -> Integer -> HP.String 249 | pad n = (\x -> HP.replicate (n HP.- HP.length x) '0' ++ x) . HP.show 250 | 251 | printBalances :: forall effs. Member Emulator.PrintEffect effs 252 | => Map.Map Entity Value 253 | -> Eff effs () 254 | printBalances m = do 255 | forM_ (Map.toList m) $ \(e, v) -> do 256 | printLn $ HP.show e <> ": " 257 | forM_ (flattenValue v) $ \(cs, tn, a) -> 258 | printLn $ " {" <> HP.show cs <> ", " <> 259 | HP.show tn <> "}: " <> HP.show a 260 | 261 | runEmulatorTraceEff 262 | :: forall effs. Member Emulator.PrintEffect effs 263 | => TraceConfig 264 | -> EmulatorConfig 265 | -> EmulatorTrace () 266 | -> Eff effs () 267 | runEmulatorTraceEff tcfg cfg t = 268 | let (xs, me, e) = Emulator.runEmulatorTrace cfg t 269 | balances' = balances (_chainState e) (_walletStates e) 270 | in do 271 | case me of 272 | Nothing -> return () 273 | Just err -> printLn $ "ERROR: " <> HP.show err 274 | 275 | forM_ xs $ \ete -> do 276 | case Emulator.showEvent tcfg (_eteEvent ete) of 277 | Nothing -> return () 278 | Just s -> 279 | let slot = pad 5 (getSlot $ _eteEmulatorTime ete) 280 | in printLn ("Slot " <> slot <> ": ") >> 281 | Control.Monad.mapM_ printLn (HP.lines s) 282 | 283 | printLn "Final balances" 284 | printBalances balances' 285 | 286 | runPrintEffect 287 | :: Handle 288 | -> Eff '[Emulator.PrintEffect, HP.IO] r 289 | -> HP.IO r 290 | runPrintEffect hdl = runM . interpretM f 291 | where 292 | f :: Emulator.PrintEffect r -> HP.IO r 293 | f = \case 294 | Emulator.PrintLn s -> hPutStrLn hdl s 295 | 296 | runEmulatorTraceIO' 297 | :: TraceConfig 298 | -> EmulatorConfig 299 | -> EmulatorTrace () 300 | -> HP.IO () 301 | runEmulatorTraceIO' tcfg cfg t 302 | = runPrintEffect (Emulator.outputHandle tcfg) $ 303 | runEmulatorTraceEff tcfg cfg t 304 | -------------------------------------------------------------------------------- /test/Tests/BusinessTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | 3 | {-| 4 | Module : Tests.BusinessTests 5 | Description : A list of tests verify the behavior of business logic operations. 6 | Copyright : P2P Solutions Ltd. 7 | License : GPL-3 8 | Maintainer : laurynas@adafinance.io 9 | Stability : develop 10 | -} 11 | 12 | module Tests.BusinessTests ( tests ) where 13 | 14 | -- Third-party libraries. 15 | import qualified Ledger (POSIXTime) 16 | import Test.Tasty 17 | import Test.Tasty.HUnit 18 | 19 | -- Internal modules. 20 | import Staking.Business.User 21 | import Staking.Business.Types 22 | import Tests.TestUtils 23 | 24 | tests :: TestTree 25 | tests = testGroup 26 | "businessTests" 27 | [ computeFeesTest 28 | , computeRewardsTests 29 | , computeDepositLevelTests 30 | , businessDepositTest 31 | , businessWithdrawTest 32 | , businessClaimTest 33 | , businessCompoundTest 34 | ] 35 | 36 | computeFeesTest :: TestTree 37 | computeFeesTest = testGroup "computeFeesTest" 38 | [ testCase "Testing the computation of deposit fees" 39 | (depositFees 33_333_333 testOperationSettings @?= outputDepositFees) 40 | , testCase "Testing the computation of withdraw fees" 41 | (withdrawFees 29_999_999 testOperationSettings @?= outputWithdrawFees) 42 | ] 43 | where 44 | -- rounding is in favour of the incentives pool 45 | outputDepositFees, outputWithdrawFees :: FeesDistribution 46 | outputDepositFees = FeesDistribution 125_001 49_999 74_999 47 | outputWithdrawFees = FeesDistribution 75_001 29_999 44_999 48 | 49 | computeRewardsTests :: TestTree 50 | computeRewardsTests = testGroup "computeRewards" 51 | [ testCase "basic" $ 52 | computeRewards [(0, 100_000_000)] (Just 0) (days 10) @?= 410_958 53 | 54 | , testCase "noDeposits" $ 55 | computeRewards [] (Just 0) (days 1) @?= 0 56 | 57 | , testCase "twoDeposits" $ 58 | let txs = [ (days 0, 100_000_000) 59 | , (days 95, 100_000_000) 60 | ] 61 | lClaim = Just 0 62 | now = days 120 63 | reward = 6_575_342 -- 120 days, 100 P2P, level 2 64 | + 1_027_397 -- 25 days, 100 P2P, level 1 65 | in 66 | computeRewards txs lClaim now @?= reward 67 | 68 | , testCase "lastClaim" $ 69 | let txs = [(1596059100999 :: Ledger.POSIXTime, 32916667)] 70 | -- 2s before deposit 71 | lClaim = Just (1596059098999 :: Ledger.POSIXTime) 72 | -- 100s after deposit 73 | now = 1596059200999 :: Ledger.POSIXTime 74 | reward = 15 75 | in 76 | computeRewards txs lClaim now @?= reward 77 | ] 78 | 79 | computeDepositLevelTests :: TestTree 80 | computeDepositLevelTests = testGroup "getLevel" 81 | [ testCase "duration000" $ depositLevel 0 0 @?= 1 82 | , testCase "duration089" $ depositLevel 0 (days 89) @?= 1 83 | , testCase "duration090" $ depositLevel 0 (days 90) @?= 2 84 | , testCase "duration091" $ depositLevel 0 (days 91) @?= 2 85 | , testCase "duration180" $ depositLevel 0 (days 180) @?= 2 86 | , testCase "dep001duration090" $ depositLevel (days 1) (days 91) @?= 2 87 | , testCase "dep020duration089" $ depositLevel (days 20) (days 109) @?= 1 88 | , testCase "dep090duration010" $ depositLevel (days 90) (days 100) @?= 1 89 | , testCase "dep050duration091" $ depositLevel (days 50) (days 141) @?= 2 90 | ] 91 | 92 | 93 | businessDepositTest :: TestTree 94 | businessDepositTest = testGroup "businessDepositTest" 95 | [ testCase 96 | "Testing a single time deposit with an amount lower than minDeposit" 97 | (deposit uStateTest 999 (days 0) testOperationSettings @?= Nothing) 98 | 99 | , testCase 100 | "Testing a single time deposit with the same amount of minDeposit" $ 101 | let 102 | uStateOutput = uStateTest { deposits = [(days 0, outputValue)] } 103 | outputValue = 1_000_000 - (3_750 + 1_500 + 2_250) 104 | value = 1_000_000 105 | fees = FeesDistribution 3_750 1_500 2_250 106 | result = Just (uStateOutput, fees) 107 | in 108 | deposit uStateTest value (days 0) testOperationSettings @?= result 109 | 110 | , testCase 111 | "Testing a single time deposit with amount greater than minDeposit" $ 112 | let 113 | uStateOutput = uStateTest { deposits = [(days 0, outputValue)] } 114 | outputValue = 10_000_000 - (37_500 + 15_000 + 22_500) 115 | value = 10_000_000 116 | fees = FeesDistribution 37_500 15_000 22_500 117 | result = Just (uStateOutput, fees) 118 | in 119 | deposit uStateTest value (days 0) testOperationSettings @?= result 120 | 121 | , testCase 122 | "Testing a second deposit with an amount greater than minDeposit" $ 123 | let 124 | uState = uStateTest { deposits = [(days 0, 10_000_000)] } 125 | uStateOutput = uStateTest { deposits = [(days 1, outputValue), 126 | (days 0, 10_000_000)] } 127 | outputValue = 20_000_000 - (75_000 + 30_000 + 45_000) 128 | value = 20_000_000 129 | fees = FeesDistribution 75_000 30_000 45_000 130 | result = Just (uStateOutput, fees) 131 | in 132 | deposit uState value (days 1) testOperationSettings @?= result 133 | ] 134 | where 135 | uStateTest :: UserState 136 | uStateTest = mkUserState user1WalletPKH [] Nothing 137 | 138 | businessWithdrawTest :: TestTree 139 | businessWithdrawTest = testGroup "businessWithdrawTest" 140 | [ testCase 141 | "Testing withdraw from an empty list of deposits" $ 142 | let 143 | uStateEmptyTest = mkUserState user1WalletPKH [] Nothing 144 | value = 2_000_000 145 | in 146 | withdraw uStateEmptyTest value testOperationSettings @?= Nothing 147 | 148 | , testCase 149 | "Testing withdraw an amount lower than the minWithdraw" 150 | (withdraw uStateTest 999 testOperationSettings @?= Nothing) 151 | 152 | , testCase 153 | "Testing withdraw the same amount of minWithdraw" $ 154 | let 155 | uStateOutput = uStateTest { deposits = [(days 0, 99_000_000)] } 156 | value = 1_000_000 157 | fees = FeesDistribution 2_500 1_000 1_500 158 | result = Just (uStateOutput, fees) 159 | in 160 | withdraw uStateTest value testOperationSettings @?= result 161 | 162 | , testCase 163 | "Testing withdraw the same amount of minWithdraw on multiple deposits" $ 164 | let 165 | uState = uStateTest { deposits = [(days 2, 200_000), 166 | (days 1, 300_000), 167 | (days 0, 1_000_000)] } 168 | uStateMultOutput = uStateTest { deposits = [(days 0, 500_000)] } 169 | value = 1_000_000 170 | fees = FeesDistribution 2_500 1_000 1_500 171 | result = Just (uStateMultOutput, fees) 172 | in 173 | withdraw uState value testOperationSettings @?= result 174 | 175 | , testCase 176 | "Testing withdraw an amount greater than the minWithdraw" $ 177 | let 178 | uStateOutput = uStateTest { deposits = [(days 0, 98_000_000)] } 179 | value = 2_000_000 180 | fees = FeesDistribution 5_000 2_000 3_000 181 | result = Just (uStateOutput, fees) 182 | in 183 | withdraw uStateTest value testOperationSettings @?= result 184 | 185 | , testCase 186 | ("Testing withdraw an amount greater than minWithdraw on multiple " ++ 187 | "deposits") $ 188 | let 189 | uState = uStateTest { deposits = [(days 2, 5_000_000), 190 | (days 1, 20_000_000), 191 | (days 0, 75_000_000)] } 192 | uStateOutput = uStateTest { deposits = [(days 0, 70_000_000)] } 193 | value = 30_000_000 194 | fees = FeesDistribution 75_000 30_000 45_000 195 | result = Just (uStateOutput, fees) 196 | in 197 | withdraw uState value testOperationSettings @?= result 198 | 199 | , testCase 200 | "Testing withdraw a valid amount lower than the totalAmount" $ 201 | let 202 | uStateOutput = uStateTest { deposits = [(days 0, 1_000_000)] } 203 | value = 99_000_000 204 | fees = FeesDistribution 247_500 99_000 148_500 205 | result = Just (uStateOutput, fees) 206 | in 207 | withdraw uStateTest value testOperationSettings @?= result 208 | 209 | , testCase 210 | "Testing withdraw the same amount of totalAmount" $ 211 | let 212 | uStateOutput = uStateTest { deposits = [] } 213 | value = 100_000_000 214 | fees = FeesDistribution 250_000 100_000 150_000 215 | result = Just (uStateOutput, fees) 216 | in 217 | withdraw uStateTest value testOperationSettings @?= result 218 | 219 | , testCase 220 | "Testing withdraw an amount greater than totalAmount" 221 | (withdraw uStateTest 100_000_001 testOperationSettings @?= Nothing) 222 | 223 | , testCase 224 | ("Testing withdraw an amount greater than totalAmount on multiple" ++ 225 | "deposits") 226 | (withdraw uStateTest 100_000_001 testOperationSettings @?= Nothing) 227 | ] 228 | where 229 | uStateTest :: UserState 230 | uStateTest = mkUserState user1WalletPKH [(days 0, 100_000_000)] Nothing 231 | 232 | businessClaimTest :: TestTree 233 | businessClaimTest = testGroup "businessClaimTest" 234 | [ testCase 235 | "Testing claim rewards from an empty list of deposits" $ 236 | let 237 | uStateEmptyTest = mkUserState user1WalletPKH [] Nothing 238 | now = days 1 239 | in 240 | claim uStateEmptyTest now testOperationSettings @?= Nothing 241 | 242 | , testCase 243 | "Testing claim a reward lower than the minClaim" $ 244 | let 245 | uState = uStateTest { deposits = [(days 0, 100_000_000)] } 246 | now = 21023 :: Ledger.POSIXTime 247 | in 248 | claim uState now testOperationSettings @?= Nothing 249 | 250 | , testCase 251 | "Testing claim the same amount of minClaim with level 1" $ 252 | let 253 | now = 4204800000 :: Ledger.POSIXTime 254 | rewards = 10_000_000 255 | result = Just (uStateOutputTest now, rewards) 256 | in 257 | claim uStateTest now testOperationSettings @?= result 258 | 259 | , testCase 260 | "Testing claim the same amount of minClaim with level 2" $ 261 | let 262 | uState = uStateTest { deposits = [(days 0, 202_777_779)] } 263 | uStateOutput = uState { lastClaim = Just now } 264 | now = days 90 265 | rewards = 10_000_000 266 | result = Just (uStateOutput, rewards) 267 | in 268 | claim uState now testOperationSettings @?= result 269 | 270 | , testCase 271 | "Testing claim a reward greater than minClaim with level 1 and 89 days" $ 272 | let 273 | now = days 89 274 | rewards = 18_287_671 275 | result = Just (uStateOutputTest now, rewards) 276 | in 277 | claim uStateTest now testOperationSettings @?= result 278 | 279 | , testCase 280 | "Testing claim a reward greater than minClaim with level 2 and 90 days" $ 281 | let 282 | now = days 90 283 | rewards = 24_657_534 284 | result = Just (uStateOutputTest now, rewards) 285 | in 286 | claim uStateTest now testOperationSettings @?= result 287 | 288 | , testCase 289 | "Testing claim a reward greater than minClaim with level 2 and 91 days" $ 290 | let 291 | now = days 91 292 | rewards = 24_931_506 293 | result = Just (uStateOutputTest now, rewards) 294 | in 295 | claim uStateTest now testOperationSettings @?= result 296 | ] 297 | where 298 | uStateTest :: UserState 299 | uStateTest = mkUserState user1WalletPKH [(days 0, 500_000_000)] Nothing 300 | 301 | uStateOutputTest :: Ledger.POSIXTime -> UserState 302 | uStateOutputTest now = uStateTest { lastClaim = Just now } 303 | 304 | businessCompoundTest :: TestTree 305 | businessCompoundTest = testGroup "businessCompoundTest" 306 | [ testCase 307 | "Testing compound rewards from an empty list of deposits" $ 308 | let 309 | uStateEmptyTest = mkUserState user1WalletPKH [] Nothing 310 | now = days 1 311 | in 312 | compound uStateEmptyTest now testOperationSettings @?= Nothing 313 | 314 | , testCase 315 | "Testing compound a reward lower than the minClaim" $ 316 | let 317 | uState = uStateTest { deposits = [(days 0, 100_000_000)] } 318 | now = 21023 :: Ledger.POSIXTime 319 | in 320 | compound uState now testOperationSettings @?= Nothing 321 | 322 | , testCase 323 | "Testing compound the same amount of minClaim with level 1" $ 324 | let 325 | now = 4204800000 :: Ledger.POSIXTime 326 | rewards = 10_000_000 327 | result = uStateOutputTest now rewards 328 | in 329 | compound uStateTest now testOperationSettings @?= result 330 | 331 | , testCase 332 | "Testing compound the same amount of minClaim with level 2" $ 333 | let 334 | uState = uStateTest { deposits = [(days 0, 202_777_779)] } 335 | uStateOutput = uState { deposits = 336 | (now, rewards) : deposits uState 337 | , lastClaim = Just now } 338 | now = days 90 339 | rewards = 10_000_000 340 | result = Just (uStateOutput, rewards) 341 | in 342 | compound uState now testOperationSettings @?= result 343 | 344 | , testCase 345 | ("Testing compound a reward greater than minClaim with level 2 and " ++ 346 | "89 days") $ 347 | let 348 | now = days 89 349 | rewards = 18_287_671 350 | result = uStateOutputTest now rewards 351 | in 352 | compound uStateTest now testOperationSettings @?= result 353 | 354 | , testCase 355 | ("Testing compound a reward greater than minClaim with level 2 and " ++ 356 | "90 days") $ 357 | let 358 | now = days 90 359 | rewards = 24_657_534 360 | result = uStateOutputTest now rewards 361 | in 362 | compound uStateTest now testOperationSettings @?= result 363 | 364 | , testCase 365 | ("Testing compound a reward greater than minClaim with level 2 and " ++ 366 | "91 days") $ 367 | let 368 | now = days 91 369 | rewards = 24_931_506 370 | result = uStateOutputTest now rewards 371 | in 372 | compound uStateTest now testOperationSettings @?= result 373 | ] 374 | where 375 | uStateTest :: UserState 376 | uStateTest = mkUserState user1WalletPKH [(days 0, 500_000_000)] Nothing 377 | 378 | uStateOutputTest :: Ledger.POSIXTime -> Integer -> Maybe (UserState,Integer) 379 | uStateOutputTest now rews = let 380 | uStateOutput = uStateTest { deposits = (now, rews) : deposits uStateTest 381 | , lastClaim = Just now } 382 | in Just (uStateOutput, rews) 383 | -------------------------------------------------------------------------------- /src/Staking/OffChain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | 8 | {-| 9 | Module : Staking.OffChain 10 | Description : Off-chain code of the staking pool. 11 | Copyright : P2P Solutions Ltd. 12 | License : GPL-3 13 | Maintainer : laurynas@adafinance.io 14 | Stability : develop 15 | -} 16 | 17 | module Staking.OffChain 18 | ( StakingSchema 19 | , runStaking 20 | -- ^ Endpoints 21 | , stakingEndpoints 22 | , userEndpoints 23 | -- ^ Utils 24 | , findStaking 25 | ) where 26 | 27 | -- GHC libraries. 28 | import Control.Monad 29 | import qualified Data.Map as Map 30 | import Data.Monoid (Last (..)) 31 | import Data.Text as T (Text, pack) 32 | 33 | -- Third-party libraries libraries. 34 | import Ledger hiding (singleton) 35 | import qualified Ledger.Ada as Ada 36 | import Ledger.Constraints as Constraints 37 | import Ledger.Value as Value 38 | import Plutus.Contract as Contract 39 | import Plutus.Contracts.Currency as Currency 40 | 41 | -- Internal modules. 42 | import qualified Staking.Business as Business 43 | import Staking.Types 44 | import Staking.Validator 45 | import Staking.Tokens 46 | import MainToken 47 | import Utils.OffChain 48 | 49 | -- Schema. 50 | type StakingSchema = Endpoint "feed" MainToken 51 | .\/ Endpoint "register" () 52 | .\/ Endpoint "unregister" () 53 | .\/ Endpoint "deposit" MainToken 54 | .\/ Endpoint "withdraw" MainToken 55 | .\/ Endpoint "claim" () 56 | .\/ Endpoint "compound" () 57 | 58 | runStaking 59 | :: MainToken 60 | -> StakingSettings 61 | -> Contract (Last Staking) StakingSchema Text () 62 | runStaking am sett = do 63 | staking <- start am sett 64 | tell $ Last $ Just staking 65 | stakingEndpoints staking 66 | 67 | stakingEndpoints :: Staking -> Contract (Last Staking) StakingSchema Text () 68 | stakingEndpoints staking = forever $ handleError logError $ awaitPromise 69 | feedEndpoint 70 | where 71 | feedEndpoint :: Promise (Last Staking) StakingSchema Text () 72 | feedEndpoint = endpoint @"feed" $ feed staking 73 | 74 | userEndpoints :: Staking -> Contract (Last Staking) StakingSchema Text () 75 | userEndpoints staking = forever $ handleError logError $ awaitPromise $ 76 | registerEndpoint `select` 77 | unregisterEndpoint `select` 78 | depositEndpoint `select` 79 | withdrawEndpoint `select` 80 | claimEndpoint `select` 81 | compoundEndpoint 82 | where 83 | registerEndpoint :: Promise (Last Staking) StakingSchema Text () 84 | registerEndpoint = endpoint @"register" (const $ register staking) 85 | 86 | unregisterEndpoint :: Promise (Last Staking) StakingSchema Text () 87 | unregisterEndpoint = endpoint @"unregister" (const $ unregister staking) 88 | 89 | depositEndpoint :: Promise (Last Staking) StakingSchema Text () 90 | depositEndpoint = endpoint @"deposit" $ deposit staking 91 | 92 | withdrawEndpoint :: Promise (Last Staking) StakingSchema Text () 93 | withdrawEndpoint = endpoint @"withdraw" $ withdraw staking 94 | 95 | claimEndpoint :: Promise (Last Staking) StakingSchema Text () 96 | claimEndpoint = endpoint @"claim" $ const $ claim staking 97 | 98 | compoundEndpoint :: Promise (Last Staking) StakingSchema Text () 99 | compoundEndpoint = endpoint @"compound" $ const $ compound staking 100 | 101 | -- Off-chain code. 102 | start 103 | :: MainToken 104 | -> StakingSettings 105 | -> Contract (Last Staking) s Text Staking 106 | start am sett = do 107 | ownPKH <- Contract.ownPubKeyHash 108 | nftCS <- Currency.currencySymbol <$> forgeNFT ownPKH stakingNFTName 109 | 110 | let stakingAC = assetClass nftCS stakingNFTName 111 | staking = Staking { nft = stakingAC, settings = sett } 112 | valNFT = assetClassValue stakingAC 1 113 | val = mainTokenValue $ getMicroToken am 114 | minAda = Ada.toValue Ledger.minAdaTxOut 115 | 116 | lookupsInit = 117 | Constraints.typedValidatorLookups (typedValidatorStaking staking) 118 | <> Constraints.otherScript (validatorStaking staking) 119 | tx = Constraints.mustPayToTheScript (mkPoolDatum []) $ val 120 | <> valNFT 121 | <> minAda 122 | 123 | submittedTx <- submitTxConstraintsWith lookupsInit tx 124 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 125 | logInfo @String $ unwords 126 | ["Staking pool has been created. Identifying NFT:" 127 | , show staking 128 | ] 129 | return staking 130 | 131 | feed :: Staking -> MainToken -> Contract w s Text () 132 | feed staking am 133 | | getMicroToken am > 0 = do 134 | (orefStaking, oStaking) <- findStaking staking 135 | stakingDat <- getContractDatum oStaking 136 | 137 | let newDat = stakingDat 138 | oldVal = getChainIndexTxOutValue oStaking 139 | newVal = oldVal <> mainTokenValue (getMicroToken am) 140 | 141 | red = feedRedeemer am 142 | lookups = mkLookups staking [(orefStaking, oStaking)] 143 | tx = 144 | Constraints.mustSpendScriptOutput orefStaking red 145 | <> Constraints.mustPayToTheScript newDat newVal 146 | 147 | submittedTx <- submitTxConstraintsWith lookups tx 148 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 149 | logInfo @String $ unwords 150 | [ "Staking fed with", show am, "micro MyToken tokens." ] 151 | | otherwise = logInfo @String 152 | $ "Rejecting transaction which tries to feed a negative amount." 153 | 154 | register :: Staking -> Contract w s Text () 155 | register staking = do 156 | (orefStaking, oStaking) <- findStaking staking 157 | activeUsers <- getPoolState oStaking 158 | ownPKH <- Contract.ownPubKeyHash 159 | userNFTCS <- Currency.currencySymbol <$> 160 | forgeNFT ownPKH userNFTName 161 | 162 | let userNFT = assetClass userNFTCS userNFTName 163 | stakingDat = PoolDatum $ Business.register activeUsers ownPKH userNFT 164 | stakingVal = getChainIndexTxOutValue oStaking 165 | userState = mkUserDatum ownPKH [] Nothing 166 | userVal = assetClassValue (assetClass userNFTCS userNFTName) 1 167 | userMinAda = Ada.toValue Ledger.minAdaTxOut 168 | 169 | red = registerRedeemer ownPKH userNFT 170 | lookups = mkLookups staking [(orefStaking, oStaking)] 171 | tx = Constraints.mustSpendScriptOutput orefStaking red 172 | <> Constraints.mustPayToTheScript stakingDat stakingVal 173 | <> Constraints.mustPayToTheScript userState 174 | (userVal <> userMinAda) 175 | 176 | submittedTx <- submitTxConstraintsWith lookups tx 177 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 178 | logInfo @String $ unwords [ "User with public key hash" 179 | , show ownPKH 180 | , "has been registered to the staking pool." 181 | ] 182 | 183 | unregister :: Staking -> Contract w s Text () 184 | unregister staking = do 185 | ownPKH <- Contract.ownPubKeyHash 186 | (orefStaking, oStaking) <- findStaking staking 187 | (orefUser, oUser) <- findUserUTxO staking ownPKH 188 | activeUsers <- getPoolState oStaking 189 | userNFT <- getUserNFT staking ownPKH 190 | 191 | if not $ ownPKH `Business.isRegistered` activeUsers 192 | then logInfo @String "User is not currently registered." 193 | else if getChainIndexTxOutValue oUser /= (assetClassValue userNFT 1 194 | <> Ada.toValue Ledger.minAdaTxOut) 195 | then logInfo @String 196 | $ "User must remove all assets in the script before unregistering." 197 | else do 198 | let newStakingDat = PoolDatum $ Business.unregister activeUsers ownPKH 199 | newStakingVal = getChainIndexTxOutValue oStaking 200 | oldUserVal = getChainIndexTxOutValue oUser 201 | minusMinAda = Ada.toValue (-Ledger.minAdaTxOut) 202 | newUserVal = oldUserVal <> assetClassValue userNFT (-1) 203 | <> minusMinAda 204 | 205 | red = unregisterRedeemer ownPKH 206 | lookups = mkLookups staking [ (orefStaking, oStaking) 207 | , (orefUser, oUser) 208 | ] 209 | tx = 210 | Constraints.mustSpendScriptOutput orefStaking red 211 | <> Constraints.mustSpendScriptOutput orefUser red 212 | <> Constraints.mustPayToTheScript newStakingDat newStakingVal 213 | <> Constraints.mustPayToPubKey ownPKH newUserVal 214 | 215 | submittedTx <- submitTxConstraintsWith lookups tx 216 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 217 | logInfo @String $ unwords 218 | [ "User with public key hash" 219 | , show ownPKH 220 | , "has been unregistered from the staking pool." 221 | ] 222 | 223 | deposit :: Staking -> MainToken -> Contract w s Text () 224 | deposit staking@Staking{..} am = do 225 | cTime <- currentTime 226 | ownPKH <- Contract.ownPubKeyHash 227 | (orefUser, oUser) <- findUserUTxO staking ownPKH 228 | oldUserState <- getUserState oUser 229 | 230 | let depositRes = Business.deposit oldUserState (getMicroToken am) 231 | cTime (opSettings settings) 232 | 233 | case depositRes of 234 | Nothing -> logInfo @String $ 235 | "Intended amount is lower than minimum allowed for deposits." 236 | Just (newUserState,feesD) -> do 237 | let refFees = Business.refillFees feesD 238 | dFees = Business.daoFees feesD 239 | aFees = Business.affFees feesD 240 | 241 | oldUserVal = getChainIndexTxOutValue oUser 242 | totalFees = refFees + dFees + aFees 243 | deposited = getMicroToken am - totalFees 244 | newUserVal = oldUserVal <> mainTokenValue deposited 245 | newUserDatum = UserDatum newUserState 246 | minAda = Ada.toValue Ledger.minAdaTxOut 247 | 248 | range = interval cTime (cTime + Business.validTimeRange) 249 | red = depositRedeemer am cTime 250 | 251 | lookups = mkLookups staking [ (orefUser, oUser) ] 252 | 253 | tx = Constraints.mustSpendScriptOutput orefUser red 254 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 255 | <> Constraints.mustValidateIn range 256 | <> Constraints.mustPayToPubKey 257 | (refWallet settings) (mainTokenValue refFees <> minAda) 258 | <> Constraints.mustPayToPubKey 259 | (daoWallet settings) (mainTokenValue dFees <> minAda) 260 | <> Constraints.mustPayToPubKey 261 | (affWallet settings) (mainTokenValue aFees <> minAda) 262 | 263 | submittedTx <- submitTxConstraintsWith lookups tx 264 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 265 | logInfo @String $ unwords 266 | [ "User deposited", show am, "micro MyToken to their" 267 | , "script UTxO, and paid", show totalFees 268 | , "micro MyToken in fees." 269 | ] 270 | 271 | withdraw :: Staking -> MainToken -> Contract w s Text () 272 | withdraw staking@Staking{..} am = do 273 | cTime <- currentTime 274 | ownPKH <- Contract.ownPubKeyHash 275 | (orefUser, oUser) <- findUserUTxO staking ownPKH 276 | oldUserState <- getUserState oUser 277 | 278 | let withdrawRes = Business.withdraw oldUserState (getMicroToken am) 279 | (opSettings settings) 280 | case withdrawRes of 281 | Nothing -> logInfo @String $ 282 | "Intended amount is lower than minimum allowed for withdrawals." 283 | Just (newUserState,feesW) -> do 284 | let refFees = Business.refillFees feesW 285 | dFees = Business.daoFees feesW 286 | aFees = Business.affFees feesW 287 | 288 | oldUserVal = getChainIndexTxOutValue oUser 289 | newUserVal = oldUserVal <> mainTokenValue (- getMicroToken am) 290 | newUserDatum = UserDatum newUserState 291 | minAda = Ada.toValue Ledger.minAdaTxOut 292 | 293 | range = interval cTime (cTime + Business.validTimeRange) 294 | red = withdrawRedeemer am cTime 295 | 296 | lookups = mkLookups staking [ (orefUser, oUser) ] 297 | 298 | tx = Constraints.mustSpendScriptOutput orefUser red 299 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 300 | <> Constraints.mustValidateIn range 301 | <> Constraints.mustPayToPubKey 302 | (refWallet settings) (mainTokenValue refFees <> minAda) 303 | <> Constraints.mustPayToPubKey 304 | (daoWallet settings) (mainTokenValue dFees <> minAda) 305 | <> Constraints.mustPayToPubKey 306 | (affWallet settings) (mainTokenValue aFees <> minAda) 307 | <> Constraints.mustPayToPubKey 308 | ownPKH (mainTokenValue (getMicroToken am) <> minAda) 309 | 310 | submittedTx <- submitTxConstraintsWith lookups tx 311 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 312 | logInfo @String $ unwords 313 | [ "User withdraw", show am 314 | , "micro MyToken from their script UTxO, and paid" 315 | , show (refFees + dFees + aFees) 316 | , "micro MyToken in fees." 317 | ] 318 | 319 | claim :: Staking -> Contract w s Text () 320 | claim staking@Staking{..} = do 321 | cTime <- currentTime 322 | ownPKH <- Contract.ownPubKeyHash 323 | (orefStaking, oStaking) <- findStaking staking 324 | activeUsers <- getPoolState oStaking 325 | (orefUser, oUser) <- findUserUTxO staking ownPKH 326 | oldUserState <- getUserState oUser 327 | 328 | let claimRes = Business.claim oldUserState cTime (opSettings settings) 329 | 330 | case claimRes of 331 | Nothing -> logInfo @String $ 332 | "Claimable rewards do not yet reach the minimum ammount." 333 | Just (newUserState, rews) -> do 334 | void $ checkMinFundsPoolUTxO staking rews 335 | let oldStakingVal = getChainIndexTxOutValue oStaking 336 | newStakingVal = oldStakingVal <> mainTokenValue (-rews) 337 | newStakingDat = PoolDatum activeUsers 338 | newUserDatum = UserDatum newUserState 339 | newUserVal = getChainIndexTxOutValue oUser 340 | minAda = Ada.toValue Ledger.minAdaTxOut 341 | 342 | range = interval cTime (cTime + Business.validTimeRange) 343 | red = claimRedeemer 344 | (MicroToken { getMicroToken = rews }) 345 | cTime 346 | 347 | lookups = mkLookups staking [ (orefStaking, oStaking) 348 | , (orefUser, oUser) 349 | ] 350 | 351 | tx = Constraints.mustSpendScriptOutput orefStaking red 352 | <> Constraints.mustSpendScriptOutput orefUser red 353 | <> Constraints.mustPayToTheScript newStakingDat newStakingVal 354 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 355 | <> Constraints.mustValidateIn range 356 | <> Constraints.mustPayToPubKey 357 | ownPKH (mainTokenValue rews <> minAda) 358 | 359 | submittedTx <- submitTxConstraintsWith lookups tx 360 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 361 | logInfo @String $ unwords 362 | [ "User has claimed their rewards (" 363 | , show rews 364 | , "micro MyToken)." 365 | ] 366 | 367 | compound :: Staking -> Contract w s Text () 368 | compound staking@Staking{..} = do 369 | cTime <- currentTime 370 | ownPKH <- Contract.ownPubKeyHash 371 | (orefStaking, oStaking) <- findStaking staking 372 | (orefUser, oUser) <- findUserUTxO staking ownPKH 373 | activeUsers <- getPoolState oStaking 374 | oldUserState <- getUserState oUser 375 | 376 | let compoundRes = Business.compound oldUserState cTime (opSettings settings) 377 | 378 | case compoundRes of 379 | Nothing -> logInfo @String $ 380 | "Claimable rewards do not yet reach the minimum ammount." 381 | Just (newUserState, rews) -> do 382 | void $ checkMinFundsPoolUTxO staking rews 383 | let oldStakingVal = getChainIndexTxOutValue oStaking 384 | newStakingVal = oldStakingVal <> mainTokenValue (-rews) 385 | newStakingDat = PoolDatum activeUsers 386 | newUserDatum = UserDatum newUserState 387 | 388 | oldUserVal = getChainIndexTxOutValue oUser 389 | newUserVal = oldUserVal <> mainTokenValue rews 390 | 391 | range = interval cTime (cTime + Business.validTimeRange) 392 | red = compoundRedeemer 393 | (MicroToken { getMicroToken = rews }) 394 | cTime 395 | 396 | lookups = mkLookups staking [ (orefStaking, oStaking) 397 | , (orefUser, oUser) 398 | ] 399 | 400 | tx = Constraints.mustSpendScriptOutput orefStaking red 401 | <> Constraints.mustSpendScriptOutput orefUser red 402 | <> Constraints.mustPayToTheScript newStakingDat newStakingVal 403 | <> Constraints.mustPayToTheScript newUserDatum newUserVal 404 | <> Constraints.mustValidateIn range 405 | 406 | submittedTx <- submitTxConstraintsWith lookups tx 407 | void $ awaitTxConfirmed $ getCardanoTxId submittedTx 408 | logInfo @String $ unwords 409 | [ "User has compounded their rewards (" 410 | , show rews 411 | , "micro MyToken)." 412 | ] 413 | 414 | -- Helper functions. 415 | mkLookups 416 | :: Staking 417 | -> [(TxOutRef, ChainIndexTxOut)] 418 | -> ScriptLookups StakingType 419 | mkLookups p utxos = Constraints.typedValidatorLookups (typedValidatorStaking p) 420 | <> Constraints.otherScript (validatorStaking p) 421 | <> Constraints.unspentOutputs (Map.fromList utxos) 422 | 423 | -- | Monadic function returning the UTxO corresponding to the staking pool. 424 | findStaking 425 | :: Staking 426 | -> Contract w s Text (TxOutRef, ChainIndexTxOut) 427 | findStaking staking@Staking{..} = lookupScriptUTxO (addressStaking staking) nft 428 | 429 | -- | Monadic function for getting the datum from a staking pool UTxO. 430 | getPoolState 431 | :: ChainIndexTxOut 432 | -> Contract w s T.Text Business.PoolState 433 | getPoolState o = 434 | case getChainIndexTxOutDatum o of 435 | Just (PoolDatum ps) -> return ps 436 | Just (UserDatum _) -> 437 | throwError "Expected StakingDatum but found UserDatum." 438 | Nothing -> throwError "Cannot find contract datum." 439 | 440 | {- | Monadic function returning the user script UTxO corresponding to the 441 | PubKeyHash. -} 442 | findUserUTxO 443 | :: Staking 444 | -> PubKeyHash 445 | -> Contract w s Text (TxOutRef, ChainIndexTxOut) 446 | findUserUTxO staking pkh = do 447 | (_, oStaking) <- findStaking staking 448 | dat <- getContractDatum oStaking 449 | case dat of 450 | UserDatum _ -> throwError 451 | "Expected StakingDatum but found UserDatum in staking script UTxO." 452 | PoolDatum ps -> 453 | case Business.getUserNFT ps pkh of 454 | Just userNFT -> lookupScriptUTxO 455 | (addressStaking staking) 456 | userNFT 457 | _ -> throwError "Could not find user NFT." 458 | 459 | {- | Monadic function for getting the AssetClass associated with the 460 | PubKeyHash value in the Staking value. -} 461 | getUserNFT 462 | :: Staking 463 | -> PubKeyHash 464 | -> Contract w s Text AssetClass 465 | getUserNFT staking@Staking{..} pkh = do 466 | (_, oStaking) <- lookupScriptUTxO (addressStaking staking) nft 467 | activeUsers <- getContractDatum oStaking 468 | case activeUsers of 469 | UserDatum _ -> throwError 470 | "Expected StakingDatum but found UserDatum in staking script UTxO." 471 | PoolDatum ps -> 472 | case Business.getUserNFT ps pkh of 473 | Just userNFT -> return userNFT 474 | _ -> throwError "Could not find user NFT." 475 | 476 | -- | Monadic function for getting the UserState from a user script UTxO. 477 | getUserState 478 | :: ChainIndexTxOut 479 | -> Contract w s T.Text Business.UserState 480 | getUserState o = case getChainIndexTxOutDatum o of 481 | Just dat -> case dat of 482 | PoolDatum _ -> 483 | throwError "Expected UserDatum but found StakingDatum." 484 | UserDatum res -> return res 485 | Nothing -> throwError "Cannot find contract datum." 486 | 487 | -- | Monadic function for getting the datum from a ChainIndexTxOut. 488 | getContractDatum 489 | :: ChainIndexTxOut 490 | -> Contract w s T.Text StakingDatum 491 | getContractDatum = 492 | maybe (throwError "Cannot find contract datum") return . 493 | getChainIndexTxOutDatum 494 | 495 | {- | Monadic function for checking if there is enough funds in pool UTxO for a 496 | claim or compound transaction -} 497 | checkMinFundsPoolUTxO 498 | :: Staking 499 | -> Integer 500 | -> Contract w s T.Text () 501 | checkMinFundsPoolUTxO staking rews = do 502 | (_, oStaking) <- findStaking staking 503 | when 504 | (assetClassValueOf (getChainIndexTxOutValue oStaking) mainTokenAC < rews) 505 | $ throwError $ pack $ unwords 506 | [ "Claim or Compound transaction not issued due to" 507 | , "unsufficient funds in pool UTxO." 508 | ] 509 | --------------------------------------------------------------------------------