mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-14 19:02:53 +01:00
started with oracle
This commit is contained in:
Lars Brünjes
parent
18b7aaacb8
commit
99c82929d6
6 changed files with 267 additions and 96 deletions
|
|
@ -21,6 +21,7 @@ source-repository-package
|
||||||
plutus-ledger-api
|
plutus-ledger-api
|
||||||
plutus-tx
|
plutus-tx
|
||||||
plutus-tx-plugin
|
plutus-tx-plugin
|
||||||
|
plutus-use-cases
|
||||||
prettyprinter-configurable
|
prettyprinter-configurable
|
||||||
quickcheck-dynamic
|
quickcheck-dynamic
|
||||||
tag: 476409eaee94141e2fe076a7821fc2fcdec5dfcb
|
tag: 476409eaee94141e2fe076a7821fc2fcdec5dfcb
|
||||||
|
|
|
||||||
|
|
@ -10,7 +10,9 @@ License-files: LICENSE
|
||||||
|
|
||||||
library
|
library
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
exposed-modules: Week06.Oracle
|
exposed-modules: Week06.Oracle.Core
|
||||||
|
Week06.Oracle.Playground
|
||||||
|
Week06.Oracle.Test
|
||||||
build-depends: aeson
|
build-depends: aeson
|
||||||
, base ^>=4.14.1.0
|
, base ^>=4.14.1.0
|
||||||
, containers
|
, containers
|
||||||
|
|
@ -21,6 +23,7 @@ library
|
||||||
, plutus-ledger-api
|
, plutus-ledger-api
|
||||||
, plutus-tx-plugin
|
, plutus-tx-plugin
|
||||||
, plutus-tx
|
, plutus-tx
|
||||||
|
, plutus-use-cases
|
||||||
, text
|
, text
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise
|
ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise
|
||||||
|
|
|
||||||
|
|
@ -1,95 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
|
|
||||||
module Week06.Oracle where
|
|
||||||
|
|
||||||
import Control.Monad hiding (fmap)
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Data.Void (Void)
|
|
||||||
import Plutus.Contract as Contract hiding (when)
|
|
||||||
import Plutus.Trace.Emulator as Emulator
|
|
||||||
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.Value as Value
|
|
||||||
import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
|
|
||||||
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
|
|
||||||
import Playground.Types (KnownCurrency (..))
|
|
||||||
import Prelude (Semigroup (..))
|
|
||||||
import Text.Printf (printf)
|
|
||||||
import Wallet.Emulator.Wallet
|
|
||||||
|
|
||||||
{-# INLINABLE mkPolicy #-}
|
|
||||||
mkPolicy :: TxOutRef -> TokenName -> ScriptContext -> Bool
|
|
||||||
mkPolicy oref tn ctx = traceIfFalse "UTxO not consumed" hasUTxO &&
|
|
||||||
traceIfFalse "wrong amount minted" checkMintedAmount
|
|
||||||
where
|
|
||||||
info :: TxInfo
|
|
||||||
info = scriptContextTxInfo ctx
|
|
||||||
|
|
||||||
hasUTxO :: Bool
|
|
||||||
hasUTxO = any (\i -> txInInfoOutRef i == oref) $ txInfoInputs info
|
|
||||||
|
|
||||||
checkMintedAmount :: Bool
|
|
||||||
checkMintedAmount = case flattenValue (txInfoForge info) of
|
|
||||||
[(cs, tn', amt)] -> cs == ownCurrencySymbol ctx && tn' == tn && amt == 1
|
|
||||||
_ -> False
|
|
||||||
|
|
||||||
policy :: TxOutRef -> TokenName -> Scripts.MonetaryPolicy
|
|
||||||
policy oref tn = mkMonetaryPolicyScript $
|
|
||||||
$$(PlutusTx.compile [|| \oref' tn' -> Scripts.wrapMonetaryPolicy $ mkPolicy oref' tn' ||])
|
|
||||||
`PlutusTx.applyCode`
|
|
||||||
PlutusTx.liftCode oref
|
|
||||||
`PlutusTx.applyCode`
|
|
||||||
PlutusTx.liftCode tn
|
|
||||||
|
|
||||||
curSymbol :: TxOutRef -> TokenName -> CurrencySymbol
|
|
||||||
curSymbol oref tn = scriptCurrencySymbol $ policy oref tn
|
|
||||||
|
|
||||||
type NFTSchema =
|
|
||||||
BlockchainActions
|
|
||||||
.\/ Endpoint "mint" TokenName
|
|
||||||
|
|
||||||
mint :: TokenName -> Contract w NFTSchema Text ()
|
|
||||||
mint tn = do
|
|
||||||
pk <- Contract.ownPubKey
|
|
||||||
utxos <- utxoAt (pubKeyAddress pk)
|
|
||||||
case Map.keys utxos of
|
|
||||||
[] -> Contract.logError @String "no utxo found"
|
|
||||||
oref : _ -> do
|
|
||||||
let val = Value.singleton (curSymbol oref tn) tn 1
|
|
||||||
lookups = Constraints.monetaryPolicy (policy oref tn) <> Constraints.unspentOutputs utxos
|
|
||||||
tx = Constraints.mustForgeValue val <> Constraints.mustSpendPubKeyOutput oref
|
|
||||||
ledgerTx <- submitTxConstraintsWith @Void lookups tx
|
|
||||||
void $ awaitTxConfirmed $ txId ledgerTx
|
|
||||||
Contract.logInfo @String $ printf "forged %s" (show val)
|
|
||||||
|
|
||||||
endpoints :: Contract () NFTSchema Text ()
|
|
||||||
endpoints = mint' >> endpoints
|
|
||||||
where
|
|
||||||
mint' = endpoint @"mint" >>= mint
|
|
||||||
|
|
||||||
mkSchemaDefinitions ''NFTSchema
|
|
||||||
|
|
||||||
mkKnownCurrencies []
|
|
||||||
|
|
||||||
test :: IO ()
|
|
||||||
test = runEmulatorTraceIO $ do
|
|
||||||
let tn = "ABC"
|
|
||||||
h1 <- activateContractWallet (Wallet 1) endpoints
|
|
||||||
h2 <- activateContractWallet (Wallet 2) endpoints
|
|
||||||
callEndpoint @"mint" h1 tn
|
|
||||||
callEndpoint @"mint" h2 tn
|
|
||||||
void $ Emulator.waitNSlots 1
|
|
||||||
174
code/week06/src/Week06/Oracle/Core.hs
Normal file
174
code/week06/src/Week06/Oracle/Core.hs
Normal file
|
|
@ -0,0 +1,174 @@
|
||||||
|
{-# 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.Core
|
||||||
|
( 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
|
||||||
33
code/week06/src/Week06/Oracle/Playground.hs
Normal file
33
code/week06/src/Week06/Oracle/Playground.hs
Normal file
|
|
@ -0,0 +1,33 @@
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
module Week06.Oracle.Playground where
|
||||||
|
|
||||||
|
import Control.Monad hiding (fmap)
|
||||||
|
import qualified Data.Map as Map
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Data.Void (Void)
|
||||||
|
import GHC.Generics (Generic)
|
||||||
|
import Plutus.Contract as Contract hiding (when)
|
||||||
|
import Plutus.Trace.Emulator as Emulator
|
||||||
|
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.Value as Value
|
||||||
|
import Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
|
||||||
|
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
|
||||||
|
import Playground.Types (KnownCurrency (..))
|
||||||
|
import Prelude (Semigroup (..))
|
||||||
|
import Text.Printf (printf)
|
||||||
|
import Wallet.Emulator.Wallet
|
||||||
55
code/week06/src/Week06/Oracle/Test.hs
Normal file
55
code/week06/src/Week06/Oracle/Test.hs
Normal file
|
|
@ -0,0 +1,55 @@
|
||||||
|
{-# 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.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 Week06.Oracle.Core
|
||||||
|
|
||||||
|
test :: IO ()
|
||||||
|
test = runEmulatorTraceIO myTrace
|
||||||
|
|
||||||
|
checkOracle :: Oracle -> Contract () BlockchainActions Text a
|
||||||
|
checkOracle oracle = do
|
||||||
|
m <- findOracle oracle
|
||||||
|
case m of
|
||||||
|
Nothing -> return ()
|
||||||
|
Just (_, _, x) -> Contract.logInfo $ "Oracle value: " ++ show x
|
||||||
|
Contract.waitNSlots 1 >> checkOracle oracle
|
||||||
|
|
||||||
|
myTrace :: EmulatorTrace ()
|
||||||
|
myTrace = do
|
||||||
|
h <- activateContractWallet (Wallet 1) $ runOracle 1000000
|
||||||
|
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
|
||||||
|
|
||||||
|
where
|
||||||
|
getOracle :: ContractHandle (Last Oracle) OracleSchema Text -> EmulatorTrace Oracle
|
||||||
|
getOracle h = do
|
||||||
|
l <- observableState h
|
||||||
|
case l of
|
||||||
|
Last Nothing -> Emulator.waitNSlots 1 >> getOracle h
|
||||||
|
Last (Just oracle) -> Extras.logInfo (show oracle) >> return oracle
|
||||||
Loading…
Reference in a new issue