Plutus Playground Smart Contract

Playground.hs

-- Factoring challenge contract implemented using the [[Plutus]] interface.
-- Based on Plutus Playground Crowd Funding example.

import           Control.Applicative                  (Applicative (pure))
import           Control.Monad                        (void)
import           Language.Plutus.Contract
import qualified Language.Plutus.Contract.Constraints as Constraints
import qualified Language.Plutus.Contract.Typed.Tx    as Typed
import qualified Language.PlutusTx                    as PlutusTx
import           Language.PlutusTx.Prelude            hiding (Applicative (..), Semigroup (..))
import           Ledger                               (PubKeyHash, TxInfo (..), Validator, ValidatorCtx (..),
                                                       pubKeyHash, txId, valueSpent)
import qualified Ledger                               as Ledger
import qualified Ledger.Ada                           as Ada
import qualified Ledger.Contexts                      as V
import qualified Ledger.Interval                      as Interval
import qualified Ledger.Scripts                       as Scripts
import           Ledger.Slot                          (Slot, SlotRange)
import qualified Ledger.Typed.Scripts                 as Scripts
import           Ledger.Value                         (Value)
import qualified Ledger.Value                         as Value
import           Playground.Contract
import           Prelude                              (Semigroup (..))
import qualified Prelude                              as Haskell
import qualified Wallet.Emulator                      as Emulator

-- | A factoring challenge.
data Challenge = Challenge
    {product   :: Integer -- The integer to be factored.
    , deadline :: Slot    -- The date by which the integer must be factored.
    } deriving (Generic, Show, ToJSON, FromJSON, ToSchema)

PlutusTx.makeIsData ''Challenge
PlutusTx.makeLift ''Challenge

-- | Used to claim the prize.
data Factor = Factor
    { factor  :: Integer -- A non-trivial factor of the product.
    } deriving (Generic, ToJSON, FromJSON, ToSchema)

PlutusTx.makeIsData ''Factor
PlutusTx.makeLift ''Factor

-- | Actions that can be taken to redeem funds from this contract.
data Action = Claim Factor | Refund

PlutusTx.makeIsData ''Action
PlutusTx.makeLift ''Action

type FactorChallengeSchema =
    BlockchainActions
        .\/ Endpoint "contribute" Contribution
        .\/ Endpoint "claim" Factor

data Contribution = Contribution
        { contribValue :: Value  -- How much to contribute.
        } deriving (Show, Generic, ToJSON, FromJSON, ToSchema)

PlutusTx.makeIsData ''Contribution
PlutusTx.makeLift ''Contribution

-- | The 'SlotRange' during which a refund may be claimed.
refundRange :: Challenge -> SlotRange
refundRange challenge = Interval.from (deadline challenge)

data FactorChallenge
instance Scripts.ScriptType FactorChallenge where
    type instance RedeemerType FactorChallenge = Action
    type instance DatumType FactorChallenge = PubKeyHash

scriptInstance :: Challenge -> Scripts.ScriptInstance FactorChallenge
scriptInstance challenge = Scripts.validator @FactorChallenge
    ($$(PlutusTx.compile [|| mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode challenge)
    $$(PlutusTx.compile [|| wrap ||])
    where
        wrap = Scripts.wrapValidator @PubKeyHash @Action

validRefund :: Challenge -> PubKeyHash -> TxInfo -> Bool
validRefund challenge contributor txinfo =
    -- Check that the transaction falls in the refund range of the challenge
    Interval.contains (refundRange challenge) (txInfoValidRange txinfo)
    -- Check that the transaction is signed by the contributor
    && (txinfo `V.txSignedBy` contributor)

validClaim :: Challenge -> Factor -> Bool
validClaim Challenge{product} Factor{factor} = 1 < factor && factor < product && product `modulo` factor == 0

mkValidator :: Challenge -> PubKeyHash -> Action -> ValidatorCtx -> Bool
mkValidator c actor action p = case action of
    Claim factor -> validClaim c factor
    Refund       -> validRefund c actor (valCtxTxInfo p)

-- | The validator script.
contributionScript :: Challenge -> Validator
contributionScript = Scripts.validatorScript . scriptInstance

-- | The address of a [[Challenge]]
challengeAddress :: Challenge -> Ledger.ValidatorHash
challengeAddress = Scripts.validatorHash . contributionScript

-- | The contract for the 'FactorChallenge'.
factorChallenge :: AsContractError e => Challenge -> Contract FactorChallengeSchema e ()
factorChallenge c = contribute c `select` claim c

-- | The "contribute" branch of the contract for a specific 'Challenge'. Exposes
--   an endpoint that allows the user to enter their public key and the
--   contribution. Then waits until the Challenge is over, and collects the
--   refund if the challenge was not met.
contribute :: AsContractError e => Challenge -> Contract FactorChallengeSchema e ()
contribute challenge = do
    Contribution{contribValue} <- endpoint @"contribute"
    contributor <- pubKeyHash <$> ownPubKey
    let inst = scriptInstance challenge
        tx = Constraints.mustPayToTheScript contributor contribValue
                <> Constraints.mustValidateIn (Ledger.interval 1 (deadline challenge))
    txid <- fmap txId (submitTxConstraints inst tx)

    utxo <- watchAddressUntil (Scripts.scriptAddress inst) (deadline challenge)

    -- 'utxo' is the set of unspent outputs at the challenge address at the
    -- collection deadline. If 'utxo' still contains our own contribution
    -- then we can claim a refund.

    let flt Ledger.TxOutRef{txOutRefId} _ = txid Haskell.== txOutRefId
        tx' = Typed.collectFromScriptFilter flt utxo Refund
                <> Constraints.mustValidateIn (refundRange challenge)
                <> Constraints.mustBeSignedBy contributor
    if Constraints.modifiesUtxoSet tx'
    then void (submitTxConstraintsSpending inst utxo tx')
    else pure ()

-- | Collects the reward if a proper factor is given.
claim :: AsContractError e => Challenge -> Contract FactorChallengeSchema e ()
claim challenge = do
    let inst = scriptInstance challenge
    factor <- endpoint @"claim"
    unspentOutputs <- utxoAt (Scripts.scriptAddress inst)
    let tx = Typed.collectFromScript unspentOutputs (Claim factor)
    void $ submitTxConstraintsSpending inst unspentOutputs tx


endpoints :: AsContractError e => Contract FactorChallengeSchema e ()
endpoints = factorChallenge Challenge{product = 15, deadline = 60}

mkSchemaDefinitions ''FactorChallengeSchema

$(mkKnownCurrencies [])

Simulation.json

[0,[{"simulationWallets":[{"simulatorWalletWallet":{"getWallet":1},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}},{"simulatorWalletWallet":{"getWallet":2},"simulatorWalletBalance":{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},10]]]]}}],"simulationName":"Simulation 1","simulationId":1,"simulationActions":[{"caller":{"getWallet":1},"argumentValues":{"endpointDescription":{"getEndpointDescription":"contribute"},"argument":{"contents":[["contribValue",{"getValue":[[{"unCurrencySymbol":""},[[{"unTokenName":""},9]]]],"tag":"FormValueF"}]],"tag":"FormObjectF"}},"tag":"CallEndpoint"},{"blocks":10,"tag":"AddBlocks"},{"caller":{"getWallet":2},"argumentValues":{"endpointDescription":{"getEndpointDescription":"claim"},"argument":{"contents":[["factor",{"s":1,"e":0,"c":[5],"tag":"FormIntegerF"}]],"tag":"FormObjectF"}},"tag":"CallEndpoint"},{"blocks":10,"tag":"AddBlocks"}]}]]