mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-21 22:32:00 +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-tx
|
||||
plutus-tx-plugin
|
||||
plutus-use-cases
|
||||
prettyprinter-configurable
|
||||
quickcheck-dynamic
|
||||
tag: 476409eaee94141e2fe076a7821fc2fcdec5dfcb
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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