mirror of
https://github.com/FiloSpaTeam/plutus-pioneer-program.git
synced 2024-11-13 10:22:34 +01:00
first working version of EvenOdd
This commit is contained in:
Lars Brünjes
parent
3c22f742fc
commit
d9f053a00f
4 changed files with 380 additions and 201 deletions
|
|
@ -10,7 +10,8 @@ License-files: LICENSE
|
|||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
exposed-modules: Week07.Oracle.Core
|
||||
exposed-modules: Week07.EvenOdd
|
||||
, Week07.Test
|
||||
build-depends: aeson
|
||||
, base ^>=4.14.1.0
|
||||
, containers
|
||||
|
|
|
|||
313
code/week07/src/Week07/EvenOdd.hs
Normal file
313
code/week07/src/Week07/EvenOdd.hs
Normal file
|
|
@ -0,0 +1,313 @@
|
|||
{-# 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 Week07.EvenOdd
|
||||
( Game (..)
|
||||
, GameChoice (..)
|
||||
, FirstParams (..)
|
||||
, SecondParams (..)
|
||||
, GameSchema
|
||||
, endpoints
|
||||
) where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text (Text)
|
||||
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 Playground.Contract (ToSchema)
|
||||
import Prelude (Semigroup (..))
|
||||
import qualified Prelude
|
||||
|
||||
data Game = Game
|
||||
{ gFirst :: !PubKeyHash
|
||||
, gSecond :: !PubKeyHash
|
||||
, gStake :: !Integer
|
||||
, gPlayDeadline :: !Slot
|
||||
, gRevealDeadline :: !Slot
|
||||
} deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord)
|
||||
|
||||
PlutusTx.makeLift ''Game
|
||||
|
||||
data GameChoice = Zero | One
|
||||
deriving (Show, Generic, FromJSON, ToJSON, ToSchema, Prelude.Eq, Prelude.Ord)
|
||||
|
||||
instance Eq GameChoice where
|
||||
{-# INLINABLE (==) #-}
|
||||
Zero == Zero = True
|
||||
One == One = True
|
||||
_ == _ = False
|
||||
|
||||
PlutusTx.unstableMakeIsData ''GameChoice
|
||||
|
||||
data GameDatum = GameDatum ByteString (Maybe GameChoice)
|
||||
deriving Show
|
||||
|
||||
instance Eq GameDatum where
|
||||
{-# INLINABLE (==) #-}
|
||||
GameDatum bs mc == GameDatum bs' mc' = (bs == bs') && (mc == mc')
|
||||
|
||||
PlutusTx.unstableMakeIsData ''GameDatum
|
||||
|
||||
data GameRedeemer = Play GameChoice | Reveal ByteString | ClaimFirst | ClaimSecond
|
||||
deriving Show
|
||||
|
||||
PlutusTx.unstableMakeIsData ''GameRedeemer
|
||||
|
||||
{-# INLINABLE lovelaces #-}
|
||||
lovelaces :: Value -> Integer
|
||||
lovelaces = Ada.getLovelace . Ada.fromValue
|
||||
|
||||
{-# INLINABLE mkGameValidator #-}
|
||||
mkGameValidator :: Game -> ByteString -> ByteString -> GameDatum -> GameRedeemer -> ScriptContext -> Bool
|
||||
mkGameValidator game bsZero' bsOne' dat red ctx = case (dat, red) of
|
||||
(GameDatum bs Nothing, Play c) ->
|
||||
traceIfFalse "not signed by second player" (txSignedBy info (gSecond game)) &&
|
||||
traceIfFalse "first player's stake missing" (lovelaces (txOutValue ownInput) == gStake game) &&
|
||||
traceIfFalse "second player's stake missing" (lovelaces (txOutValue ownOutput) == (2 * gStake game)) &&
|
||||
traceIfFalse "wrong output datum" (outputDatum == GameDatum bs (Just c)) &&
|
||||
traceIfFalse "missed deadline" (to (gPlayDeadline game) `contains` txInfoValidRange info)
|
||||
|
||||
(GameDatum bs (Just c), Reveal nonce) ->
|
||||
traceIfFalse "not signed by first player" (txSignedBy info (gFirst game)) &&
|
||||
traceIfFalse "commit mismatch" (checkNonce bs nonce c) &&
|
||||
traceIfFalse "missed deadline" (to (gRevealDeadline game) `contains` txInfoValidRange info)
|
||||
|
||||
(GameDatum _ Nothing, ClaimFirst) ->
|
||||
traceIfFalse "not signed by first player" (txSignedBy info (gFirst game)) &&
|
||||
traceIfFalse "too early" (from (1 + gPlayDeadline game) `contains` txInfoValidRange info)
|
||||
|
||||
(GameDatum _ (Just _), ClaimSecond) ->
|
||||
traceIfFalse "not signed by second player" (txSignedBy info (gSecond game)) &&
|
||||
traceIfFalse "to early" (from (1 + gRevealDeadline game) `contains` txInfoValidRange info)
|
||||
|
||||
_ -> False
|
||||
where
|
||||
info :: TxInfo
|
||||
info = scriptContextTxInfo ctx
|
||||
|
||||
ownInput :: TxOut
|
||||
ownInput = case findOwnInput ctx of
|
||||
Nothing -> traceError "game input missing"
|
||||
Just i -> txInInfoResolved i
|
||||
|
||||
ownOutput :: TxOut
|
||||
ownOutput = case getContinuingOutputs ctx of
|
||||
[o] -> o
|
||||
_ -> traceError "expected exactly one game output"
|
||||
|
||||
outputDatum :: GameDatum
|
||||
outputDatum = case m of
|
||||
Nothing -> traceError "game output datum not found"
|
||||
Just d -> d
|
||||
where
|
||||
m :: Maybe GameDatum
|
||||
m = do
|
||||
dh <- txOutDatum ownOutput
|
||||
Datum d <- findDatum dh info
|
||||
PlutusTx.fromData d
|
||||
|
||||
checkNonce :: ByteString -> ByteString -> GameChoice -> Bool
|
||||
checkNonce bs nonce cSecond = sha2_256 (nonce `concatenate` cFirst) == bs
|
||||
where
|
||||
cFirst :: ByteString
|
||||
cFirst = case cSecond of
|
||||
Zero -> bsZero'
|
||||
One -> bsOne'
|
||||
|
||||
data Gaming
|
||||
instance Scripts.ScriptType Gaming where
|
||||
type instance DatumType Gaming = GameDatum
|
||||
type instance RedeemerType Gaming = GameRedeemer
|
||||
|
||||
bsZero, bsOne :: ByteString
|
||||
bsZero = "0"
|
||||
bsOne = "1"
|
||||
|
||||
gameInst :: Game -> Scripts.ScriptInstance Gaming
|
||||
gameInst game = Scripts.validator @Gaming
|
||||
($$(PlutusTx.compile [|| mkGameValidator ||])
|
||||
`PlutusTx.applyCode` PlutusTx.liftCode game
|
||||
`PlutusTx.applyCode` PlutusTx.liftCode bsZero
|
||||
`PlutusTx.applyCode` PlutusTx.liftCode bsOne)
|
||||
$$(PlutusTx.compile [|| wrap ||])
|
||||
where
|
||||
wrap = Scripts.wrapValidator @GameDatum @GameRedeemer
|
||||
|
||||
gameValidator :: Game -> Validator
|
||||
gameValidator = Scripts.validatorScript . gameInst
|
||||
|
||||
gameAddress :: Game -> Ledger.Address
|
||||
gameAddress = scriptAddress . gameValidator
|
||||
|
||||
data FirstParams = FirstParams
|
||||
{ fpSecond :: !PubKeyHash
|
||||
, fpStake :: !Integer
|
||||
, fpPlayDeadline :: !Slot
|
||||
, fpRevealDeadline :: !Slot
|
||||
, fpNonce :: !ByteString
|
||||
, fpChoice :: !GameChoice
|
||||
} deriving (Show, Generic, FromJSON, ToJSON, ToSchema)
|
||||
|
||||
firstGame :: forall w s. HasBlockchainActions s => FirstParams -> Contract w s Text ()
|
||||
firstGame fp = do
|
||||
pkh <- pubKeyHash <$> Contract.ownPubKey
|
||||
let game = Game
|
||||
{ gFirst = pkh
|
||||
, gSecond = fpSecond fp
|
||||
, gStake = fpStake fp
|
||||
, gPlayDeadline = fpPlayDeadline fp
|
||||
, gRevealDeadline = fpRevealDeadline fp
|
||||
}
|
||||
v = lovelaceValueOf $ fpStake fp
|
||||
c = fpChoice fp
|
||||
bs = sha2_256 $ fpNonce fp `concatenate` if c == Zero then bsZero else bsOne
|
||||
tx = Constraints.mustPayToTheScript (GameDatum bs Nothing) v
|
||||
ledgerTx <- submitTxConstraints (gameInst game) tx
|
||||
void $ awaitTxConfirmed $ txId ledgerTx
|
||||
logInfo @String $ "made first move: " ++ show (fpChoice fp)
|
||||
|
||||
void $ awaitSlot $ 1 + fpPlayDeadline fp
|
||||
|
||||
m <- findOutput game bs c
|
||||
case m of
|
||||
Nothing -> logInfo @String "no opportunity to win"
|
||||
Just (oref, o, Nothing) -> do
|
||||
logInfo @String "second player did not play"
|
||||
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
|
||||
Constraints.otherScript (gameValidator game)
|
||||
tx' = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData ClaimFirst)
|
||||
ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx'
|
||||
void $ awaitTxConfirmed $ txId ledgerTx'
|
||||
logInfo @String "reclaimed stake"
|
||||
Just (oref, o, Just _) -> do
|
||||
logInfo @String "second player played and lost"
|
||||
let lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
|
||||
Constraints.otherScript (gameValidator game)
|
||||
tx' = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData $ Reveal $ fpNonce fp) <>
|
||||
Constraints.mustValidateIn (to $ fpRevealDeadline fp)
|
||||
ledgerTx' <- submitTxConstraintsWith @Gaming lookups tx'
|
||||
void $ awaitTxConfirmed $ txId ledgerTx'
|
||||
logInfo @String "victory"
|
||||
where
|
||||
findOutput :: Game -> ByteString -> GameChoice -> Contract w s Text (Maybe (TxOutRef, TxOutTx, Maybe GameChoice))
|
||||
findOutput game bs c = do
|
||||
utxos <- utxoAt $ gameAddress game
|
||||
return $ case mapMaybe f $ Map.toList utxos of
|
||||
[] -> Nothing
|
||||
xs -> case find (\(_, _, mc) -> isJust mc) xs of
|
||||
Nothing -> Just $ head xs -- we know this list is not empty, because we are in the second case
|
||||
Just x -> Just x
|
||||
where
|
||||
f :: (TxOutRef, TxOutTx) -> Maybe (TxOutRef, TxOutTx, Maybe GameChoice)
|
||||
f (oref, o) = do
|
||||
guard $ lovelaces (txOutValue $ txOutTxOut o) == 2 * fpStake fp
|
||||
dh <- txOutDatum $ txOutTxOut o
|
||||
Datum d <- Map.lookup dh $ txData $ txOutTxTx o
|
||||
dat <- PlutusTx.fromData d
|
||||
case dat of
|
||||
GameDatum bs' mc
|
||||
| bs' == bs && (isNothing mc || mc == Just c) -> return (oref, o, mc)
|
||||
_ -> Nothing
|
||||
|
||||
data SecondParams = SecondParams
|
||||
{ spFirst :: !PubKeyHash
|
||||
, spStake :: !Integer
|
||||
, spPlayDeadline :: !Slot
|
||||
, spRevealDeadline :: !Slot
|
||||
, spChoice :: !GameChoice
|
||||
} deriving (Show, Generic, FromJSON, ToJSON, ToSchema)
|
||||
|
||||
secondGame :: forall w s. HasBlockchainActions s => SecondParams -> Contract w s Text ()
|
||||
secondGame sp = do
|
||||
pkh <- pubKeyHash <$> Contract.ownPubKey
|
||||
let game = Game
|
||||
{ gFirst = spFirst sp
|
||||
, gSecond = pkh
|
||||
, gStake = spStake sp
|
||||
, gPlayDeadline = spPlayDeadline sp
|
||||
, gRevealDeadline = spRevealDeadline sp
|
||||
}
|
||||
m <- findOutput game
|
||||
case m of
|
||||
Nothing -> logInfo @String "no running game found"
|
||||
Just (oref, o, bs) -> do
|
||||
logInfo @String "running game found"
|
||||
let v = lovelaceValueOf $ spStake sp
|
||||
c = spChoice sp
|
||||
lookups = Constraints.unspentOutputs (Map.singleton oref o) <>
|
||||
Constraints.otherScript (gameValidator game) <>
|
||||
Constraints.scriptInstanceLookups (gameInst game)
|
||||
tx = Constraints.mustSpendScriptOutput oref (Redeemer $ PlutusTx.toData $ Play c) <>
|
||||
Constraints.mustPayToTheScript (GameDatum bs $ Just c) (v <> v) <>
|
||||
Constraints.mustValidateIn (to $ spPlayDeadline sp)
|
||||
ledgerTx <- submitTxConstraintsWith @Gaming lookups tx
|
||||
let tid = txId ledgerTx
|
||||
void $ awaitTxConfirmed tid
|
||||
logInfo @String $ "made second move: " ++ show (spChoice sp)
|
||||
|
||||
void $ awaitSlot $ 1 + spRevealDeadline sp
|
||||
|
||||
m' <- findOutput' game tid
|
||||
case m' of
|
||||
Nothing -> logInfo @String "first player won"
|
||||
Just (oref', o') -> do
|
||||
logInfo @String "first player didn't reveal"
|
||||
let lookups' = Constraints.unspentOutputs (Map.singleton oref' o') <>
|
||||
Constraints.otherScript (gameValidator game)
|
||||
tx' = Constraints.mustSpendScriptOutput oref' (Redeemer $ PlutusTx.toData ClaimSecond) <>
|
||||
Constraints.mustValidateIn (from $ 1 + spRevealDeadline sp)
|
||||
ledgerTx' <- submitTxConstraintsWith @Gaming lookups' tx'
|
||||
void $ awaitTxConfirmed $ txId ledgerTx'
|
||||
logInfo @String "second player won"
|
||||
where
|
||||
findOutput :: Game -> Contract w s Text (Maybe (TxOutRef, TxOutTx, ByteString))
|
||||
findOutput game = do
|
||||
now <- currentSlot
|
||||
if now > spPlayDeadline sp
|
||||
then return Nothing
|
||||
else do
|
||||
utxos <- utxoAt $ gameAddress game
|
||||
return $ case mapMaybe f $ Map.toList utxos of
|
||||
[] -> Nothing
|
||||
x : _ -> Just x
|
||||
where
|
||||
f :: (TxOutRef, TxOutTx) -> Maybe (TxOutRef, TxOutTx, ByteString)
|
||||
f (oref, o) = do
|
||||
guard $ lovelaces (txOutValue $ txOutTxOut o) == spStake sp
|
||||
dh <- txOutDatum $ txOutTxOut o
|
||||
Datum d <- Map.lookup dh $ txData $ txOutTxTx o
|
||||
dat <- PlutusTx.fromData d
|
||||
case dat of
|
||||
GameDatum bs Nothing -> return (oref, o, bs)
|
||||
_ -> Nothing
|
||||
|
||||
findOutput' :: Game -> TxId -> Contract w s Text (Maybe (TxOutRef, TxOutTx))
|
||||
findOutput' game tid = do
|
||||
utxos <- utxoAt $ gameAddress game
|
||||
return $ find (\(oref, _) -> txOutRefId oref == tid) $ Map.toList utxos
|
||||
|
||||
type GameSchema = BlockchainActions .\/ Endpoint "first" FirstParams .\/ Endpoint "second" SecondParams
|
||||
|
||||
endpoints :: Contract () GameSchema Text ()
|
||||
endpoints = (first `select` second) >> endpoints
|
||||
where
|
||||
first = endpoint @"first" >>= firstGame
|
||||
second = endpoint @"second" >>= secondGame
|
||||
|
|
@ -1,200 +0,0 @@
|
|||
{-# 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 Week07.Oracle.Core
|
||||
( Oracle (..)
|
||||
, OracleRedeemer (..)
|
||||
, oracleTokenName
|
||||
, oracleValue
|
||||
, oracleAsset
|
||||
, oracleInst
|
||||
, oracleValidator
|
||||
, oracleAddress
|
||||
, OracleSchema
|
||||
, OracleParams (..)
|
||||
, 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.Value as Value
|
||||
import Ledger.Ada as Ada
|
||||
import Plutus.Contracts.Currency as Currency
|
||||
import Prelude (Semigroup (..))
|
||||
import qualified Prelude as Prelude
|
||||
|
||||
data Oracle = Oracle
|
||||
{ oSymbol :: !CurrencySymbol
|
||||
, oOperator :: !PubKeyHash
|
||||
, oFee :: !Integer
|
||||
, oAsset :: !AssetClass
|
||||
} deriving (Show, Generic, FromJSON, ToJSON, Prelude.Eq, Prelude.Ord)
|
||||
|
||||
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 oracleValue #-}
|
||||
oracleValue :: TxOut -> (DatumHash -> Maybe Datum) -> Maybe Integer
|
||||
oracleValue o f = do
|
||||
dh <- txOutDatum o
|
||||
Datum d <- f dh
|
||||
PlutusTx.fromData d
|
||||
|
||||
{-# INLINABLE mkOracleValidator #-}
|
||||
mkOracleValidator :: Oracle -> Integer -> OracleRedeemer -> ScriptContext -> Bool
|
||||
mkOracleValidator oracle x r ctx =
|
||||
traceIfFalse "token missing from input" inputHasToken &&
|
||||
traceIfFalse "token missing from output" outputHasToken &&
|
||||
case r of
|
||||
Update -> traceIfFalse "operator signature missing" (txSignedBy info $ oOperator oracle) &&
|
||||
traceIfFalse "invalid output datum" validOutputDatum
|
||||
Use -> traceIfFalse "oracle value changed" (outputDatum == Just x) &&
|
||||
traceIfFalse "fees not paid" feesPaid
|
||||
where
|
||||
info :: TxInfo
|
||||
info = scriptContextTxInfo ctx
|
||||
|
||||
ownInput :: TxOut
|
||||
ownInput = case findOwnInput ctx of
|
||||
Nothing -> traceError "oracle input missing"
|
||||
Just i -> txInInfoResolved i
|
||||
|
||||
inputHasToken :: Bool
|
||||
inputHasToken = assetClassValueOf (txOutValue ownInput) (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
|
||||
|
||||
outputDatum :: Maybe Integer
|
||||
outputDatum = oracleValue ownOutput (`findDatum` info)
|
||||
|
||||
validOutputDatum :: Bool
|
||||
validOutputDatum = isJust outputDatum
|
||||
|
||||
feesPaid :: Bool
|
||||
feesPaid =
|
||||
let
|
||||
inVal = txOutValue ownInput
|
||||
outVal = txOutValue ownOutput
|
||||
in
|
||||
outVal `geq` (inVal <> Ada.lovelaceValueOf (oFee oracle))
|
||||
|
||||
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
|
||||
|
||||
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 = opFees op
|
||||
, oAsset = AssetClass (opSymbol op, opToken op)
|
||||
}
|
||||
logInfo @String $ "started 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
|
||||
x <- oracleValue (txOutTxOut o) $ \dh -> Map.lookup dh $ txData $ txOutTxTx o
|
||||
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 :: OracleParams -> Contract (Last Oracle) OracleSchema Text ()
|
||||
runOracle op = do
|
||||
oracle <- startOracle op
|
||||
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
|
||||
65
code/week07/src/Week07/Test.hs
Normal file
65
code/week07/src/Week07/Test.hs
Normal file
|
|
@ -0,0 +1,65 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Week07.Test where
|
||||
|
||||
import Control.Monad hiding (fmap)
|
||||
import Control.Monad.Freer.Extras as Extras
|
||||
import Ledger
|
||||
import Plutus.Trace.Emulator as Emulator
|
||||
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
||||
import Wallet.Emulator.Wallet
|
||||
|
||||
import Week07.EvenOdd
|
||||
|
||||
test :: IO ()
|
||||
test = do
|
||||
runEmulatorTraceIO $ myTrace Zero Zero
|
||||
runEmulatorTraceIO $ myTrace Zero One
|
||||
runEmulatorTraceIO $ myTrace One Zero
|
||||
runEmulatorTraceIO $ myTrace One One
|
||||
|
||||
myTrace :: GameChoice -> GameChoice -> EmulatorTrace ()
|
||||
myTrace c1 c2 = do
|
||||
Extras.logInfo $ "first move: " ++ show c1 ++ ", second move: " ++ show c2
|
||||
|
||||
h1 <- activateContractWallet (Wallet 1) endpoints
|
||||
h2 <- activateContractWallet (Wallet 2) endpoints
|
||||
|
||||
let pkh1 = pubKeyHash $ walletPubKey $ Wallet 1
|
||||
pkh2 = pubKeyHash $ walletPubKey $ Wallet 2
|
||||
|
||||
fp = FirstParams
|
||||
{ fpSecond = pkh2
|
||||
, fpStake = 5000000
|
||||
, fpPlayDeadline = 5
|
||||
, fpRevealDeadline = 10
|
||||
, fpNonce = "SECRETNONCE"
|
||||
, fpChoice = c1
|
||||
}
|
||||
sp = SecondParams
|
||||
{ spFirst = pkh1
|
||||
, spStake = 5000000
|
||||
, spPlayDeadline = 5
|
||||
, spRevealDeadline = 10
|
||||
, spChoice = c2
|
||||
}
|
||||
|
||||
callEndpoint @"first" h1 fp
|
||||
|
||||
void $ Emulator.waitNSlots 3
|
||||
|
||||
callEndpoint @"second" h2 sp
|
||||
|
||||
void $ Emulator.waitNSlots 10
|
||||
Loading…
Reference in a new issue