started with swap contract

This commit is contained in:
Lars Brünjes 2021-05-08 23:20:14 +02:00
parent 127a1432c2
commit 089c383022
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
5 changed files with 198 additions and 192 deletions

View file

@ -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

View file

@ -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

View 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
-}

View file

@ -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

View file

@ -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