diff --git a/code/week06/plutus-pioneer-program-week06.cabal b/code/week06/plutus-pioneer-program-week06.cabal index 3cd4b26..18132ec 100644 --- a/code/week06/plutus-pioneer-program-week06.cabal +++ b/code/week06/plutus-pioneer-program-week06.cabal @@ -13,6 +13,7 @@ library exposed-modules: Week06.Oracle.Core Week06.Oracle.Playground Week06.Oracle.Test + Week06.Oracle.User build-depends: aeson , base ^>=4.14.1.0 , containers diff --git a/code/week06/src/Week06/Oracle/Core.hs b/code/week06/src/Week06/Oracle/Core.hs index 9505a03..2d37921 100644 --- a/code/week06/src/Week06/Oracle/Core.hs +++ b/code/week06/src/Week06/Oracle/Core.hs @@ -20,6 +20,7 @@ module Week06.Oracle.Core , oracleValidator , oracleAddress , OracleSchema + , OracleParams (..) , runOracle , findOracle ) where @@ -45,6 +46,7 @@ data Oracle = Oracle { oSymbol :: !CurrencySymbol , oOperator :: !PubKeyHash , oFee :: !Value + , oAsset :: !AssetClass } deriving (Show, Generic, FromJSON, ToJSON) PlutusTx.makeLift ''Oracle @@ -114,15 +116,22 @@ 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 +data OracleParams = OracleParams + { opFees :: !Integer + , opSymbol :: !CurrencySymbol + , opToken :: !TokenName + } deriving (Show, Generic, FromJSON, ToJSON) + +startOracle :: forall w s. HasBlockchainActions s => OracleParams -> Contract w s Text Oracle +startOracle op = 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 + , oFee = Ada.lovelaceValueOf $ opFees op + , oAsset = AssetClass (opSymbol op, opToken op) } logInfo @String $ "forged oracle state token for oracle " ++ show oracle return oracle @@ -161,9 +170,9 @@ findOracle oracle = do type OracleSchema = BlockchainActions .\/ Endpoint "update" Integer -runOracle :: Integer -> Contract (Last Oracle) OracleSchema Text () -runOracle fees = do - oracle <- startOracle fees +runOracle :: OracleParams -> Contract (Last Oracle) OracleSchema Text () +runOracle op = do + oracle <- startOracle op tell $ Last $ Just oracle go oracle where diff --git a/code/week06/src/Week06/Oracle/Test.hs b/code/week06/src/Week06/Oracle/Test.hs index 6a0e481..4c0c8b2 100644 --- a/code/week06/src/Week06/Oracle/Test.hs +++ b/code/week06/src/Week06/Oracle/Test.hs @@ -37,7 +37,12 @@ checkOracle oracle = do myTrace :: EmulatorTrace () myTrace = do - h <- activateContractWallet (Wallet 1) $ runOracle 1000000 + let op = OracleParams + { opFees = 1000000 + , opSymbol = "ff" + , opToken = "USDT" + } + h <- activateContractWallet (Wallet 1) $ runOracle op void $ Emulator.waitNSlots 1 oracle <- getOracle h void $ activateContractWallet (Wallet 2) $ checkOracle oracle diff --git a/code/week06/src/Week06/Oracle/User.hs b/code/week06/src/Week06/Oracle/User.hs new file mode 100644 index 0000000..9040cb4 --- /dev/null +++ b/code/week06/src/Week06/Oracle/User.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.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