mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-12-22 13:31:59 +01:00
started with swap contract
This commit is contained in:
Lars Brünjes
parent
127a1432c2
commit
089c383022
5 changed files with 198 additions and 192 deletions
|
|
@ -12,8 +12,8 @@ library
|
|||
hs-source-dirs: src
|
||||
exposed-modules: Week06.Oracle.Core
|
||||
Week06.Oracle.Playground
|
||||
Week06.Oracle.Swap
|
||||
Week06.Oracle.Test
|
||||
Week06.Oracle.User
|
||||
build-depends: aeson
|
||||
, base ^>=4.14.1.0
|
||||
, containers
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ module Week06.Oracle.Core
|
|||
( Oracle (..)
|
||||
, OracleRedeemer (..)
|
||||
, oracleTokenName
|
||||
, oracleValue
|
||||
, oracleAsset
|
||||
, oracleInst
|
||||
, oracleValidator
|
||||
|
|
@ -64,6 +65,13 @@ oracleTokenName = TokenName emptyByteString
|
|||
oracleAsset :: Oracle -> AssetClass
|
||||
oracleAsset oracle = AssetClass (oSymbol oracle, oracleTokenName)
|
||||
|
||||
{-# INLINABLE oracleValue #-}
|
||||
oracleValue :: TxOut -> (DatumHash -> Maybe Datum) -> Maybe Integer
|
||||
oracleValue o f = do
|
||||
dh <- txOutDatum o
|
||||
Datum d <- f dh
|
||||
PlutusTx.fromData d
|
||||
|
||||
{-# INLINABLE mkOracleValidator #-}
|
||||
mkOracleValidator :: Oracle -> Integer -> OracleRedeemer -> ScriptContext -> Bool
|
||||
mkOracleValidator _ _ Use _ = False
|
||||
|
|
@ -90,13 +98,9 @@ mkOracleValidator oracle _ Update ctx =
|
|||
outputHasToken = assetClassValueOf (txOutValue ownOutput) (oracleAsset oracle) == 1
|
||||
|
||||
validOutputDatum :: Bool
|
||||
validOutputDatum = case txOutDatum ownOutput of
|
||||
validOutputDatum = case oracleValue ownOutput (`findDatum` info) of
|
||||
Nothing -> False
|
||||
Just dh -> case findDatum dh info of
|
||||
Nothing -> False
|
||||
Just (Datum d) -> case PlutusTx.fromData d of
|
||||
Nothing -> False
|
||||
Just (_ :: Integer) -> True
|
||||
Just _ -> True
|
||||
|
||||
data Oracling
|
||||
instance Scripts.ScriptType Oracling where
|
||||
|
|
@ -159,9 +163,7 @@ findOracle oracle = do
|
|||
utxos <- Map.filter f <$> utxoAt (oracleAddress oracle)
|
||||
return $ case Map.toList utxos of
|
||||
[(oref, o)] -> do
|
||||
dh <- txOutDatumHash $ txOutTxOut o
|
||||
(Datum d) <- Map.lookup dh $ txData $ txOutTxTx o
|
||||
x <- PlutusTx.fromData d
|
||||
x <- oracleValue (txOutTxOut o) $ \dh -> Map.lookup dh $ txData $ txOutTxTx o
|
||||
return (oref, o, x)
|
||||
_ -> Nothing
|
||||
where
|
||||
|
|
|
|||
175
code/week06/src/Week06/Oracle/Swap.hs
Normal file
175
code/week06/src/Week06/Oracle/Swap.hs
Normal file
|
|
@ -0,0 +1,175 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Week06.Oracle.Swap
|
||||
( offerSwap
|
||||
) where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Monoid (Last (..))
|
||||
import Data.Text (Text, pack)
|
||||
import GHC.Generics (Generic)
|
||||
import Plutus.Contract as Contract hiding (when)
|
||||
import qualified PlutusTx
|
||||
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 Prelude (Semigroup (..))
|
||||
|
||||
import Week06.Oracle.Core
|
||||
|
||||
{-# INLINABLE mkSwapValidator #-}
|
||||
mkSwapValidator :: Oracle -> Address -> PubKeyHash -> () -> ScriptContext -> Bool
|
||||
mkSwapValidator oracle addr pkh () ctx =
|
||||
txSignedBy info pkh ||
|
||||
(traceIfFalse "expected exactly two script inputs" hasTwoScriptInputs &&
|
||||
traceIfFalse "price not paid" sellerPaid)
|
||||
|
||||
where
|
||||
info :: TxInfo
|
||||
info = scriptContextTxInfo ctx
|
||||
|
||||
oracleInput :: TxOut
|
||||
oracleInput =
|
||||
let
|
||||
ins = [ o
|
||||
| i <- txInfoInputs info
|
||||
, let o = txInInfoResolved i
|
||||
, txOutAddress o == addr
|
||||
]
|
||||
in
|
||||
case ins of
|
||||
[o] -> o
|
||||
_ -> traceError "expected exactly one oracle input"
|
||||
|
||||
oracleValue' = case oracleValue oracleInput (`findDatum` info) of
|
||||
Nothing -> traceError "oracle value not found"
|
||||
Just x -> x
|
||||
|
||||
hasTwoScriptInputs :: Bool
|
||||
hasTwoScriptInputs =
|
||||
let
|
||||
xs = filter (isJust . toValidatorHash . txOutAddress . txInInfoResolved) $ txInfoInputs info
|
||||
in
|
||||
length xs == 2
|
||||
|
||||
minPrice :: Integer
|
||||
minPrice =
|
||||
let
|
||||
lovelaceIn = case findOwnInput ctx of
|
||||
Nothing -> traceError "own input not found"
|
||||
Just i -> Ada.getLovelace $ Ada.fromValue $ txOutValue $ txInInfoResolved i
|
||||
in
|
||||
lovelaceIn * oracleValue'
|
||||
|
||||
sellerPaid :: Bool
|
||||
sellerPaid =
|
||||
let
|
||||
pricePaid :: Integer
|
||||
pricePaid = assetClassValueOf (valuePaidTo info pkh) (oAsset oracle)
|
||||
in
|
||||
pricePaid >= minPrice
|
||||
|
||||
data Swapping
|
||||
instance Scripts.ScriptType Swapping where
|
||||
type instance DatumType Swapping = PubKeyHash
|
||||
type instance RedeemerType Swapping = ()
|
||||
|
||||
swapInst :: Oracle -> Scripts.ScriptInstance Swapping
|
||||
swapInst oracle = Scripts.validator @Swapping
|
||||
($$(PlutusTx.compile [|| mkSwapValidator ||])
|
||||
`PlutusTx.applyCode` PlutusTx.liftCode oracle
|
||||
`PlutusTx.applyCode` PlutusTx.liftCode (oracleAddress oracle))
|
||||
$$(PlutusTx.compile [|| wrap ||])
|
||||
where
|
||||
wrap = Scripts.wrapValidator @PubKeyHash @()
|
||||
|
||||
swapValidator :: Oracle -> Validator
|
||||
swapValidator = Scripts.validatorScript . swapInst
|
||||
|
||||
swapAddress :: Oracle -> Ledger.Address
|
||||
swapAddress = scriptAddress . swapValidator
|
||||
|
||||
offerSwap :: forall w s. HasBlockchainActions s => Oracle -> Integer -> Contract w s Text ()
|
||||
offerSwap oracle amt = do
|
||||
pkh <- pubKeyHash <$> Contract.ownPubKey
|
||||
let tx = Constraints.mustPayToTheScript pkh $ Ada.lovelaceValueOf amt
|
||||
ledgerTx <- submitTxConstraints (swapInst oracle) tx
|
||||
awaitTxConfirmed $ txId ledgerTx
|
||||
logInfo @String $ "offered " ++ show amt ++ " lovelace for swap"
|
||||
{-
|
||||
|
||||
startOracle :: forall w s. HasBlockchainActions s => Integer -> Contract w s Text Oracle
|
||||
startOracle fees = do
|
||||
pkh <- pubKeyHash <$> Contract.ownPubKey
|
||||
osc <- mapError (pack . show) (forgeContract pkh [(oracleTokenName, 1)] :: Contract w s CurrencyError OneShotCurrency)
|
||||
let cs = Currency.currencySymbol osc
|
||||
oracle = Oracle
|
||||
{ oSymbol = cs
|
||||
, oOperator = pkh
|
||||
, oFee = Ada.lovelaceValueOf fees
|
||||
}
|
||||
logInfo @String $ "forged oracle state token for oracle " ++ show oracle
|
||||
return oracle
|
||||
|
||||
updateOracle :: forall w s. HasBlockchainActions s => Oracle -> Integer -> Contract w s Text ()
|
||||
updateOracle oracle x = do
|
||||
m <- findOracle oracle
|
||||
let c = Constraints.mustPayToTheScript x $ assetClassValue (oracleAsset oracle) 1
|
||||
case m of
|
||||
Nothing -> do
|
||||
ledgerTx <- submitTxConstraints (oracleInst oracle) c
|
||||
awaitTxConfirmed $ txId ledgerTx
|
||||
logInfo @String $ "set initial oracle value to " ++ show x
|
||||
Just (oref, o, _) -> do
|
||||
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
|
||||
Constraints.scriptInstanceLookups (oracleInst oracle) <>
|
||||
Constraints.otherScript (oracleValidator oracle)
|
||||
tx = c <> Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData Update)
|
||||
ledgerTx <- submitTxConstraintsWith @Oracling lookups tx
|
||||
awaitTxConfirmed $ txId ledgerTx
|
||||
logInfo @String $ "updated oracle value to " ++ show x
|
||||
|
||||
findOracle :: forall w s. HasBlockchainActions s => Oracle -> Contract w s Text (Maybe (TxOutRef, TxOutTx, Integer))
|
||||
findOracle oracle = do
|
||||
utxos <- Map.filter f <$> utxoAt (oracleAddress oracle)
|
||||
return $ case Map.toList utxos of
|
||||
[(oref, o)] -> do
|
||||
dh <- txOutDatumHash $ txOutTxOut o
|
||||
(Datum d) <- Map.lookup dh $ txData $ txOutTxTx o
|
||||
x <- PlutusTx.fromData d
|
||||
return (oref, o, x)
|
||||
_ -> Nothing
|
||||
where
|
||||
f :: TxOutTx -> Bool
|
||||
f o = assetClassValueOf (txOutValue $ txOutTxOut o) (oracleAsset oracle) == 1
|
||||
|
||||
type OracleSchema = BlockchainActions .\/ Endpoint "update" Integer
|
||||
|
||||
runOracle :: Integer -> Contract (Last Oracle) OracleSchema Text ()
|
||||
runOracle fees = do
|
||||
oracle <- startOracle fees
|
||||
tell $ Last $ Just oracle
|
||||
go oracle
|
||||
where
|
||||
go :: Oracle -> Contract (Last Oracle) OracleSchema Text a
|
||||
go oracle = do
|
||||
x <- endpoint @"update"
|
||||
updateOracle oracle x
|
||||
go oracle
|
||||
-}
|
||||
|
|
@ -13,16 +13,17 @@
|
|||
|
||||
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.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 Week06.Oracle.Core
|
||||
import Week06.Oracle.Swap
|
||||
|
||||
test :: IO ()
|
||||
test = runEmulatorTraceIO myTrace
|
||||
|
|
@ -50,6 +51,8 @@ myTrace = do
|
|||
void $ Emulator.waitNSlots 3
|
||||
callEndpoint @"update" h 666
|
||||
void $ Emulator.waitNSlots 10
|
||||
h' <- activateContractWallet (Wallet 2) (offerSwap oracle 12000000 :: Contract () BlockchainActions Text ())
|
||||
void $ Emulator.waitNSlots 10
|
||||
|
||||
where
|
||||
getOracle :: ContractHandle (Last Oracle) OracleSchema Text -> EmulatorTrace Oracle
|
||||
|
|
|
|||
|
|
@ -1,174 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Week06.Oracle.User
|
||||
( Oracle (..)
|
||||
, OracleRedeemer (..)
|
||||
, oracleTokenName
|
||||
, oracleAsset
|
||||
, oracleInst
|
||||
, oracleValidator
|
||||
, oracleAddress
|
||||
, OracleSchema
|
||||
, runOracle
|
||||
, findOracle
|
||||
) where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Monoid (Last (..))
|
||||
import Data.Text (Text, pack)
|
||||
import GHC.Generics (Generic)
|
||||
import Plutus.Contract as Contract hiding (when)
|
||||
import qualified PlutusTx
|
||||
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 (..))
|
||||
|
||||
data Oracle = Oracle
|
||||
{ oSymbol :: !CurrencySymbol
|
||||
, oOperator :: !PubKeyHash
|
||||
, oFee :: !Value
|
||||
} deriving (Show, Generic, FromJSON, ToJSON)
|
||||
|
||||
PlutusTx.makeLift ''Oracle
|
||||
|
||||
data OracleRedeemer = Update | Use
|
||||
deriving Show
|
||||
|
||||
PlutusTx.unstableMakeIsData ''OracleRedeemer
|
||||
|
||||
{-# INLINABLE oracleTokenName #-}
|
||||
oracleTokenName :: TokenName
|
||||
oracleTokenName = TokenName emptyByteString
|
||||
|
||||
{-# INLINABLE oracleAsset #-}
|
||||
oracleAsset :: Oracle -> AssetClass
|
||||
oracleAsset oracle = AssetClass (oSymbol oracle, oracleTokenName)
|
||||
|
||||
{-# INLINABLE mkOracleValidator #-}
|
||||
mkOracleValidator :: Oracle -> Integer -> OracleRedeemer -> ScriptContext -> Bool
|
||||
mkOracleValidator _ _ Use _ = False
|
||||
mkOracleValidator oracle _ Update ctx =
|
||||
traceIfFalse "operator signature missing" (txSignedBy info $ oOperator oracle) &&
|
||||
traceIfFalse "token missing from input" inputHasToken &&
|
||||
traceIfFalse "token missing from output" outputHasToken &&
|
||||
traceIfFalse "invalid output datum" validOutputDatum
|
||||
where
|
||||
info :: TxInfo
|
||||
info = scriptContextTxInfo ctx
|
||||
|
||||
inputHasToken :: Bool
|
||||
inputHasToken = case findOwnInput ctx of
|
||||
Nothing -> False
|
||||
Just i -> assetClassValueOf (txOutValue $ txInInfoResolved i) (oracleAsset oracle) == 1
|
||||
|
||||
ownOutput :: TxOut
|
||||
ownOutput = case getContinuingOutputs ctx of
|
||||
[o] -> o
|
||||
_ -> traceError "expected exactly one oracle output"
|
||||
|
||||
outputHasToken :: Bool
|
||||
outputHasToken = assetClassValueOf (txOutValue ownOutput) (oracleAsset oracle) == 1
|
||||
|
||||
validOutputDatum :: Bool
|
||||
validOutputDatum = case txOutDatum ownOutput of
|
||||
Nothing -> False
|
||||
Just dh -> case findDatum dh info of
|
||||
Nothing -> False
|
||||
Just (Datum d) -> case PlutusTx.fromData d of
|
||||
Nothing -> False
|
||||
Just (_ :: Integer) -> True
|
||||
|
||||
data Oracling
|
||||
instance Scripts.ScriptType Oracling where
|
||||
type instance DatumType Oracling = Integer
|
||||
type instance RedeemerType Oracling = OracleRedeemer
|
||||
|
||||
oracleInst :: Oracle -> Scripts.ScriptInstance Oracling
|
||||
oracleInst oracle = Scripts.validator @Oracling
|
||||
($$(PlutusTx.compile [|| mkOracleValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode oracle)
|
||||
$$(PlutusTx.compile [|| wrap ||])
|
||||
where
|
||||
wrap = Scripts.wrapValidator @Integer @OracleRedeemer
|
||||
|
||||
oracleValidator :: Oracle -> Validator
|
||||
oracleValidator = Scripts.validatorScript . oracleInst
|
||||
|
||||
oracleAddress :: Oracle -> Ledger.Address
|
||||
oracleAddress = scriptAddress . oracleValidator
|
||||
|
||||
startOracle :: forall w s. HasBlockchainActions s => Integer -> Contract w s Text Oracle
|
||||
startOracle fees = do
|
||||
pkh <- pubKeyHash <$> Contract.ownPubKey
|
||||
osc <- mapError (pack . show) (forgeContract pkh [(oracleTokenName, 1)] :: Contract w s CurrencyError OneShotCurrency)
|
||||
let cs = Currency.currencySymbol osc
|
||||
oracle = Oracle
|
||||
{ oSymbol = cs
|
||||
, oOperator = pkh
|
||||
, oFee = Ada.lovelaceValueOf fees
|
||||
}
|
||||
logInfo @String $ "forged oracle state token for oracle " ++ show oracle
|
||||
return oracle
|
||||
|
||||
updateOracle :: forall w s. HasBlockchainActions s => Oracle -> Integer -> Contract w s Text ()
|
||||
updateOracle oracle x = do
|
||||
m <- findOracle oracle
|
||||
let c = Constraints.mustPayToTheScript x $ assetClassValue (oracleAsset oracle) 1
|
||||
case m of
|
||||
Nothing -> do
|
||||
ledgerTx <- submitTxConstraints (oracleInst oracle) c
|
||||
awaitTxConfirmed $ txId ledgerTx
|
||||
logInfo @String $ "set initial oracle value to " ++ show x
|
||||
Just (oref, o, _) -> do
|
||||
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
|
||||
Constraints.scriptInstanceLookups (oracleInst oracle) <>
|
||||
Constraints.otherScript (oracleValidator oracle)
|
||||
tx = c <> Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData Update)
|
||||
ledgerTx <- submitTxConstraintsWith @Oracling lookups tx
|
||||
awaitTxConfirmed $ txId ledgerTx
|
||||
logInfo @String $ "updated oracle value to " ++ show x
|
||||
|
||||
findOracle :: forall w s. HasBlockchainActions s => Oracle -> Contract w s Text (Maybe (TxOutRef, TxOutTx, Integer))
|
||||
findOracle oracle = do
|
||||
utxos <- Map.filter f <$> utxoAt (oracleAddress oracle)
|
||||
return $ case Map.toList utxos of
|
||||
[(oref, o)] -> do
|
||||
dh <- txOutDatumHash $ txOutTxOut o
|
||||
(Datum d) <- Map.lookup dh $ txData $ txOutTxTx o
|
||||
x <- PlutusTx.fromData d
|
||||
return (oref, o, x)
|
||||
_ -> Nothing
|
||||
where
|
||||
f :: TxOutTx -> Bool
|
||||
f o = assetClassValueOf (txOutValue $ txOutTxOut o) (oracleAsset oracle) == 1
|
||||
|
||||
type OracleSchema = BlockchainActions .\/ Endpoint "update" Integer
|
||||
|
||||
runOracle :: Integer -> Contract (Last Oracle) OracleSchema Text ()
|
||||
runOracle fees = do
|
||||
oracle <- startOracle fees
|
||||
tell $ Last $ Just oracle
|
||||
go oracle
|
||||
where
|
||||
go :: Oracle -> Contract (Last Oracle) OracleSchema Text a
|
||||
go oracle = do
|
||||
x <- endpoint @"update"
|
||||
updateOracle oracle x
|
||||
go oracle
|
||||
Loading…
Reference in a new issue