mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-12-22 13:31:59 +01:00
swap contract with tests
This commit is contained in:
Lars Brünjes
parent
bb2e6ee45b
commit
e5fa37a0b5
4 changed files with 125 additions and 37 deletions
|
|
@ -17,6 +17,7 @@ library
|
|||
build-depends: aeson
|
||||
, base ^>=4.14.1.0
|
||||
, containers
|
||||
, data-default
|
||||
, freer-extras
|
||||
, playground-common
|
||||
, plutus-contract
|
||||
|
|
|
|||
|
|
@ -38,7 +38,6 @@ import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
|||
import Ledger hiding (singleton)
|
||||
import Ledger.Constraints as Constraints
|
||||
import qualified Ledger.Typed.Scripts as Scripts
|
||||
import Ledger.Ada as Ada
|
||||
import Ledger.Value as Value
|
||||
import Plutus.Contracts.Currency as Currency
|
||||
import Prelude (Semigroup (..))
|
||||
|
|
@ -46,7 +45,7 @@ import Prelude (Semigroup (..))
|
|||
data Oracle = Oracle
|
||||
{ oSymbol :: !CurrencySymbol
|
||||
, oOperator :: !PubKeyHash
|
||||
, oFee :: !Value
|
||||
, oFee :: !Integer
|
||||
, oAsset :: !AssetClass
|
||||
} deriving (Show, Generic, FromJSON, ToJSON)
|
||||
|
||||
|
|
@ -74,7 +73,7 @@ oracleValue o f = do
|
|||
|
||||
{-# INLINABLE mkOracleValidator #-}
|
||||
mkOracleValidator :: Oracle -> Integer -> OracleRedeemer -> ScriptContext -> Bool
|
||||
mkOracleValidator _ _ Use _ = False
|
||||
mkOracleValidator _ _ Use _ = True
|
||||
mkOracleValidator oracle _ Update ctx =
|
||||
traceIfFalse "operator signature missing" (txSignedBy info $ oOperator oracle) &&
|
||||
traceIfFalse "token missing from input" inputHasToken &&
|
||||
|
|
@ -134,7 +133,7 @@ startOracle op = do
|
|||
oracle = Oracle
|
||||
{ oSymbol = cs
|
||||
, oOperator = pkh
|
||||
, oFee = Ada.lovelaceValueOf $ opFees op
|
||||
, oFee = opFees op
|
||||
, oAsset = AssetClass (opSymbol op, opToken op)
|
||||
}
|
||||
logInfo @String $ "forged oracle state token for oracle " ++ show oracle
|
||||
|
|
|
|||
|
|
@ -14,27 +14,35 @@
|
|||
module Week06.Oracle.Swap
|
||||
( offerSwap
|
||||
, retrieveSwaps
|
||||
, useSwap
|
||||
) where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import Data.List (find)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Monoid (Last (..))
|
||||
import Data.Text (Text, pack)
|
||||
import GHC.Generics (Generic)
|
||||
import Data.Text (Text)
|
||||
import Plutus.Contract as Contract hiding (when)
|
||||
import qualified PlutusTx
|
||||
import PlutusTx.Prelude hiding (Semigroup(..), unless, mapMaybe)
|
||||
import PlutusTx.Prelude hiding (Semigroup(..), (<$>), unless, mapMaybe, find)
|
||||
import Ledger hiding (singleton)
|
||||
import Ledger.Constraints as Constraints
|
||||
import qualified Ledger.Typed.Scripts as Scripts
|
||||
import Ledger.Ada as Ada
|
||||
import Ledger.Ada as Ada hiding (divide)
|
||||
import Ledger.Value as Value
|
||||
import Prelude (Semigroup (..))
|
||||
import Prelude (Semigroup (..), (<$>))
|
||||
|
||||
import Week06.Oracle.Core
|
||||
|
||||
{-# INLINABLE price #-}
|
||||
price :: Integer -> Integer -> Integer
|
||||
price lovelace exchangeRate = (lovelace * exchangeRate) `divide` 1000000
|
||||
|
||||
{-# INLINABLE lovelaces #-}
|
||||
lovelaces :: Value -> Integer
|
||||
lovelaces = Ada.getLovelace . Ada.fromValue
|
||||
|
||||
{-# INLINABLE mkSwapValidator #-}
|
||||
mkSwapValidator :: Oracle -> Address -> PubKeyHash -> () -> ScriptContext -> Bool
|
||||
mkSwapValidator oracle addr pkh () ctx =
|
||||
|
|
@ -75,9 +83,9 @@ mkSwapValidator oracle addr pkh () ctx =
|
|||
let
|
||||
lovelaceIn = case findOwnInput ctx of
|
||||
Nothing -> traceError "own input not found"
|
||||
Just i -> Ada.getLovelace $ Ada.fromValue $ txOutValue $ txInInfoResolved i
|
||||
Just i -> lovelaces $ txOutValue $ txInInfoResolved i
|
||||
in
|
||||
lovelaceIn * oracleValue'
|
||||
price lovelaceIn oracleValue'
|
||||
|
||||
sellerPaid :: Bool
|
||||
sellerPaid =
|
||||
|
|
@ -145,3 +153,49 @@ retrieveSwaps oracle = do
|
|||
ledgerTx <- submitTxConstraintsWith @Swapping lookups tx
|
||||
awaitTxConfirmed $ txId ledgerTx
|
||||
logInfo @String $ "retrieved " ++ show (length xs) ++ " swap(s)"
|
||||
|
||||
ownFunds :: HasBlockchainActions s => Contract w s Text Value
|
||||
ownFunds = do
|
||||
pk <- ownPubKey
|
||||
utxos <- utxoAt $ pubKeyAddress pk
|
||||
let v = mconcat $ Map.elems $ txOutValue . txOutTxOut <$> utxos
|
||||
logInfo @String $ "own funds: " ++ show (Value.flattenValue v)
|
||||
return v
|
||||
|
||||
useSwap :: forall w s. HasBlockchainActions s => Oracle -> Contract w s Text ()
|
||||
useSwap oracle = do
|
||||
funds <- ownFunds
|
||||
let amt = assetClassValueOf funds $ oAsset oracle
|
||||
logInfo @String $ "available assets: " ++ show amt
|
||||
|
||||
m <- findOracle oracle
|
||||
case m of
|
||||
Nothing -> logInfo @String "oracle not found"
|
||||
Just (oref, o, x) -> do
|
||||
logInfo @String $ "found oracle, exchange rate " ++ show x
|
||||
pkh <- pubKeyHash <$> Contract.ownPubKey
|
||||
swaps <- findSwaps oracle (/= pkh)
|
||||
case find (f amt x) swaps of
|
||||
Nothing -> logInfo @String "no suitable swap found"
|
||||
Just (oref', o', pkh') -> do
|
||||
let v = txOutValue (txOutTxOut o) <> lovelaceValueOf (oFee oracle)
|
||||
p = assetClassValue (oAsset oracle) $ price (lovelaces $ txOutValue $ txOutTxOut o') x
|
||||
lookups = Constraints.otherScript (swapValidator oracle) <>
|
||||
Constraints.otherScript (oracleValidator oracle) <>
|
||||
Constraints.unspentOutputs (Map.fromList [(oref, o), (oref', o')])
|
||||
tx = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData Use) <>
|
||||
Constraints.mustSpendScriptOutput oref' (Redeemer $ PlutusTx.toData ()) <>
|
||||
Constraints.mustPayToOtherScript
|
||||
(validatorHash $ oracleValidator oracle)
|
||||
(Datum $ PlutusTx.toData x)
|
||||
v <>
|
||||
Constraints.mustPayToPubKey pkh' p
|
||||
ledgerTx <- submitTxConstraintsWith @Swapping lookups tx
|
||||
awaitTxConfirmed $ txId ledgerTx
|
||||
logInfo @String $ "made swap with price " ++ show (Value.flattenValue p)
|
||||
where
|
||||
getPrice :: Integer -> TxOutTx -> Integer
|
||||
getPrice x o = price (lovelaces $ txOutValue $ txOutTxOut o) x
|
||||
|
||||
f :: Integer -> Integer -> (TxOutRef, TxOutTx, PubKeyHash) -> Bool
|
||||
f amt x (_, o, _) = getPrice x o <= amt
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
|
@ -13,20 +14,39 @@
|
|||
|
||||
module Week06.Oracle.Test where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
import Control.Monad.Freer.Extras as Extras
|
||||
import Data.Monoid (Last (..))
|
||||
import Data.Text (Text)
|
||||
import Plutus.Contract as Contract hiding (when)
|
||||
import Plutus.Trace.Emulator as Emulator
|
||||
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||
import Wallet.Emulator.Wallet
|
||||
import Control.Monad hiding (fmap)
|
||||
import Control.Monad.Freer.Extras as Extras
|
||||
import Data.Default (Default (..))
|
||||
import qualified Data.Map as Map
|
||||
import Data.Monoid (Last (..))
|
||||
import Data.Text (Text)
|
||||
import Ledger
|
||||
import Ledger.Value as Value
|
||||
import Ledger.Ada as Ada
|
||||
import Plutus.Contract as Contract hiding (when)
|
||||
import Plutus.Trace.Emulator as Emulator
|
||||
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||
import Prelude (Semigroup(..))
|
||||
import Wallet.Emulator.Wallet
|
||||
|
||||
import Week06.Oracle.Core
|
||||
import Week06.Oracle.Swap
|
||||
import Week06.Oracle.Core
|
||||
import Week06.Oracle.Swap
|
||||
|
||||
assetSymbol :: CurrencySymbol
|
||||
assetSymbol = "ff"
|
||||
|
||||
assetToken :: TokenName
|
||||
assetToken = "USDT"
|
||||
|
||||
test :: IO ()
|
||||
test = runEmulatorTraceIO myTrace
|
||||
test = runEmulatorTraceIO' def emCfg myTrace
|
||||
where
|
||||
emCfg :: EmulatorConfig
|
||||
emCfg = EmulatorConfig $ Left $ Map.fromList [(Wallet i, v) | i <- [1 .. 10]]
|
||||
|
||||
v :: Value
|
||||
v = Ada.lovelaceValueOf 100_000_000 <>
|
||||
Value.singleton assetSymbol assetToken 100_000_000
|
||||
|
||||
checkOracle :: Oracle -> Contract () BlockchainActions Text a
|
||||
checkOracle oracle = do
|
||||
|
|
@ -39,25 +59,39 @@ checkOracle oracle = do
|
|||
myTrace :: EmulatorTrace ()
|
||||
myTrace = do
|
||||
let op = OracleParams
|
||||
{ opFees = 1000000
|
||||
, opSymbol = "ff"
|
||||
, opToken = "USDT"
|
||||
{ opFees = 1_000_000
|
||||
, opSymbol = assetSymbol
|
||||
, opToken = assetToken
|
||||
}
|
||||
|
||||
h <- activateContractWallet (Wallet 1) $ runOracle op
|
||||
void $ Emulator.waitNSlots 1
|
||||
oracle <- getOracle h
|
||||
void $ activateContractWallet (Wallet 2) $ checkOracle oracle
|
||||
callEndpoint @"update" h 42
|
||||
void $ Emulator.waitNSlots 3
|
||||
callEndpoint @"update" h 666
|
||||
void $ Emulator.waitNSlots 10
|
||||
void $ activateContractWallet (Wallet 2) (offerSwap oracle 12000000 :: Contract () BlockchainActions Text ())
|
||||
void $ Emulator.waitNSlots 10
|
||||
void $ activateContractWallet (Wallet 2) (offerSwap oracle 18000000 :: Contract () BlockchainActions Text ())
|
||||
void $ Emulator.waitNSlots 10
|
||||
void $ activateContractWallet (Wallet 2) (retrieveSwaps oracle :: Contract () BlockchainActions Text ())
|
||||
void $ Emulator.waitNSlots 10
|
||||
|
||||
void $ activateContractWallet (Wallet 2) $ checkOracle oracle
|
||||
|
||||
callEndpoint @"update" h 1_500_000
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
void $ activateContractWallet (Wallet 3) (offerSwap oracle 10_000_000 :: Contract () BlockchainActions Text ())
|
||||
void $ activateContractWallet (Wallet 4) (offerSwap oracle 20_000_000 :: Contract () BlockchainActions Text ())
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
void $ activateContractWallet (Wallet 5) (useSwap oracle :: Contract () BlockchainActions Text ())
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
callEndpoint @"update" h 1_700_000
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
void $ activateContractWallet (Wallet 5) (useSwap oracle :: Contract () BlockchainActions Text ())
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
callEndpoint @"update" h 1_800_000
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
void $ activateContractWallet (Wallet 3) (retrieveSwaps oracle :: Contract () BlockchainActions Text ())
|
||||
void $ activateContractWallet (Wallet 4) (retrieveSwaps oracle :: Contract () BlockchainActions Text ())
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
where
|
||||
getOracle :: ContractHandle (Last Oracle) OracleSchema Text -> EmulatorTrace Oracle
|
||||
|
|
|
|||
Loading…
Reference in a new issue