101 lines
3.6 KiB
Haskell
101 lines
3.6 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
|
|
|
module Week02.Homework2 where
|
|
|
|
import Control.Monad hiding (fmap)
|
|
import Data.Aeson (FromJSON, ToJSON)
|
|
import Data.Map as Map
|
|
import Data.Text (Text)
|
|
import Data.Void (Void)
|
|
import GHC.Generics (Generic)
|
|
import Plutus.Contract
|
|
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 (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
|
|
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
|
|
import Playground.Types (KnownCurrency (..))
|
|
import Prelude (IO, Semigroup (..), String, undefined)
|
|
import Text.Printf (printf)
|
|
|
|
data MyRedeemer = MyRedeemer
|
|
{ flag1 :: Bool
|
|
, flag2 :: Bool
|
|
} deriving (Generic, FromJSON, ToJSON, ToSchema)
|
|
|
|
PlutusTx.unstableMakeIsData ''MyRedeemer
|
|
|
|
{-# INLINABLE mkValidator #-}
|
|
-- This should validate if and only if the two Booleans in the redeemer are equal!
|
|
mkValidator :: () -> MyRedeemer -> ScriptContext -> Bool
|
|
mkValidator _ (MyRedeemer r x) _ = traceIfFalse "Flags dont match" $ r == x
|
|
|
|
data Typed
|
|
instance Scripts.ValidatorTypes Typed where
|
|
type instance DatumType Typed = ()
|
|
type instance RedeemerType Typed = MyRedeemer
|
|
|
|
typedValidator :: Scripts.TypedValidator Typed
|
|
typedValidator = Scripts.mkTypedValidator @Typed -- FIX ME!
|
|
$$(PlutusTx.compile [|| mkValidator ||])
|
|
$$(PlutusTx.compile [|| wrap ||])
|
|
where
|
|
wrap = Scripts.wrapValidator @() @MyRedeemer
|
|
|
|
validator :: Validator
|
|
validator = Scripts.validatorScript typedValidator -- FIX ME!
|
|
|
|
valHash :: Ledger.ValidatorHash
|
|
valHash = Scripts.validatorHash typedValidator -- FIX ME!
|
|
|
|
scrAddress :: Ledger.Address
|
|
scrAddress = scriptAddress validator -- FIX ME!
|
|
|
|
type GiftSchema =
|
|
Endpoint "give" Integer
|
|
.\/ Endpoint "grab" MyRedeemer
|
|
|
|
give :: AsContractError e => Integer -> Contract w s e ()
|
|
give amount = do
|
|
let tx = mustPayToTheScript () $ Ada.lovelaceValueOf amount
|
|
ledgerTx <- submitTxConstraints typedValidator tx
|
|
void $ awaitTxConfirmed $ txId ledgerTx
|
|
logInfo @String $ printf "made a gift of %d lovelace" amount
|
|
|
|
grab :: forall w s e. AsContractError e => MyRedeemer -> Contract w s e ()
|
|
grab r = do
|
|
utxos <- utxoAt scrAddress
|
|
let orefs = fst <$> Map.toList utxos
|
|
lookups = Constraints.unspentOutputs utxos <>
|
|
Constraints.otherScript validator
|
|
tx :: TxConstraints Void Void
|
|
tx = mconcat [mustSpendScriptOutput oref $ Redeemer $ PlutusTx.toData r | oref <- orefs]
|
|
ledgerTx <- submitTxConstraintsWith @Void lookups tx
|
|
void $ awaitTxConfirmed $ txId ledgerTx
|
|
logInfo @String $ "collected gifts"
|
|
|
|
endpoints :: Contract () GiftSchema Text ()
|
|
endpoints = (give' `select` grab') >> endpoints
|
|
where
|
|
give' = endpoint @"give" >>= give
|
|
grab' = endpoint @"grab" >>= grab
|
|
|
|
mkSchemaDefinitions ''GiftSchema
|
|
|
|
mkKnownCurrencies []
|