diff --git a/code/week06/cabal.project b/code/week06/cabal.project index 76984fa..bb7fb02 100644 --- a/code/week06/cabal.project +++ b/code/week06/cabal.project @@ -21,6 +21,7 @@ source-repository-package plutus-ledger-api plutus-tx plutus-tx-plugin + plutus-use-cases prettyprinter-configurable quickcheck-dynamic tag: 476409eaee94141e2fe076a7821fc2fcdec5dfcb diff --git a/code/week06/plutus-pioneer-program-week06.cabal b/code/week06/plutus-pioneer-program-week06.cabal index 17e8900..3cd4b26 100644 --- a/code/week06/plutus-pioneer-program-week06.cabal +++ b/code/week06/plutus-pioneer-program-week06.cabal @@ -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 diff --git a/code/week06/src/Week06/Oracle.hs b/code/week06/src/Week06/Oracle.hs deleted file mode 100644 index 5ccaf1d..0000000 --- a/code/week06/src/Week06/Oracle.hs +++ /dev/null @@ -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 diff --git a/code/week06/src/Week06/Oracle/Core.hs b/code/week06/src/Week06/Oracle/Core.hs new file mode 100644 index 0000000..9505a03 --- /dev/null +++ b/code/week06/src/Week06/Oracle/Core.hs @@ -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 diff --git a/code/week06/src/Week06/Oracle/Playground.hs b/code/week06/src/Week06/Oracle/Playground.hs new file mode 100644 index 0000000..f2e2906 --- /dev/null +++ b/code/week06/src/Week06/Oracle/Playground.hs @@ -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 diff --git a/code/week06/src/Week06/Oracle/Test.hs b/code/week06/src/Week06/Oracle/Test.hs new file mode 100644 index 0000000..6a0e481 --- /dev/null +++ b/code/week06/src/Week06/Oracle/Test.hs @@ -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