started with oracle

This commit is contained in:
Lars Brünjes 2021-05-08 21:26:38 +02:00
parent 18b7aaacb8
commit 99c82929d6
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
6 changed files with 267 additions and 96 deletions

View file

@ -21,6 +21,7 @@ source-repository-package
plutus-ledger-api
plutus-tx
plutus-tx-plugin
plutus-use-cases
prettyprinter-configurable
quickcheck-dynamic
tag: 476409eaee94141e2fe076a7821fc2fcdec5dfcb

View file

@ -10,7 +10,9 @@ License-files: LICENSE
library
hs-source-dirs: src
exposed-modules: Week06.Oracle
exposed-modules: Week06.Oracle.Core
Week06.Oracle.Playground
Week06.Oracle.Test
build-depends: aeson
, base ^>=4.14.1.0
, containers
@ -21,6 +23,7 @@ library
, plutus-ledger-api
, plutus-tx-plugin
, plutus-tx
, plutus-use-cases
, text
default-language: Haskell2010
ghc-options: -Wall -fobject-code -fno-ignore-interface-pragmas -fno-omit-interface-pragmas -fno-strictness -fno-spec-constr -fno-specialise

View file

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

View 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

View 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

View 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