114 lines
4.4 KiB
Haskell
114 lines
4.4 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
|
|
module Week05.Homework1 where
|
|
|
|
import Control.Monad hiding (fmap)
|
|
import Control.Monad.Freer.Extras as Extras
|
|
import Data.Aeson (ToJSON, FromJSON)
|
|
import Data.Default (Default (..))
|
|
import Data.Text (Text)
|
|
import Data.Void (Void)
|
|
import GHC.Generics (Generic)
|
|
import Plutus.Contract as Contract
|
|
import Plutus.Trace.Emulator as Emulator
|
|
import qualified PlutusTx
|
|
import PlutusTx.Prelude hiding (Semigroup(..), unless)
|
|
import Ledger hiding (mint, singleton)
|
|
import Ledger.Constraints as Constraints
|
|
import Ledger.TimeSlot
|
|
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 (IO, Semigroup (..), Show (..), String, undefined)
|
|
import Text.Printf (printf)
|
|
import Wallet.Emulator.Wallet
|
|
|
|
{-# INLINABLE mkPolicy #-}
|
|
-- This policy should only allow minting (or burning) of tokens if the owner of the specified PubKeyHash
|
|
-- has signed the transaction and if the specified deadline has not passed.
|
|
mkPolicy :: PubKeyHash -> POSIXTime -> () -> ScriptContext -> Bool
|
|
mkPolicy pkh deadline () ctx = traceIfFalse "not signed the transaction" txSigned &&
|
|
traceIfFalse "deadline has passed" deadlineValid
|
|
where
|
|
info :: TxInfo
|
|
info = scriptContextTxInfo ctx
|
|
|
|
txSigned :: Bool
|
|
txSigned = txSignedBy info pkh
|
|
|
|
deadlineValid :: Bool
|
|
deadlineValid = contains (to $ deadline) $ txInfoValidRange info
|
|
|
|
policy :: PubKeyHash -> POSIXTime -> Scripts.MintingPolicy
|
|
policy pkh deadline = mkMintingPolicyScript $
|
|
$$(PlutusTx.compile [|| \pkh' deadline' -> Scripts.wrapMintingPolicy $ mkPolicy pkh' deadline' ||])
|
|
`PlutusTx.applyCode`
|
|
(PlutusTx.liftCode pkh)
|
|
`PlutusTx.applyCode`
|
|
(PlutusTx.liftCode deadline)
|
|
|
|
curSymbol :: PubKeyHash -> POSIXTime -> CurrencySymbol
|
|
curSymbol pkh deadline = scriptCurrencySymbol $ policy pkh deadline
|
|
|
|
data MintParams = MintParams
|
|
{ mpTokenName :: !TokenName
|
|
, mpDeadline :: !POSIXTime
|
|
, mpAmount :: !Integer
|
|
} deriving (Generic, ToJSON, FromJSON, ToSchema)
|
|
|
|
type SignedSchema = Endpoint "mint" MintParams
|
|
|
|
mint :: MintParams -> Contract w SignedSchema Text ()
|
|
mint mp = do
|
|
pkh <- pubKeyHash <$> Contract.ownPubKey
|
|
now <- Contract.currentTime
|
|
let deadline = mpDeadline mp
|
|
if now > deadline
|
|
then Contract.logError @String "deadline passed"
|
|
else do
|
|
let val = Value.singleton (curSymbol pkh deadline) (mpTokenName mp) (mpAmount mp)
|
|
lookups = Constraints.mintingPolicy $ policy pkh deadline
|
|
tx = Constraints.mustMintValue val <> Constraints.mustValidateIn (to $ now + 5000)
|
|
ledgerTx <- submitTxConstraintsWith @Void lookups tx
|
|
void $ awaitTxConfirmed $ txId ledgerTx
|
|
Contract.logInfo @String $ printf "forged %s" (show val)
|
|
|
|
endpoints :: Contract () SignedSchema Text ()
|
|
endpoints = mint' >> endpoints
|
|
where
|
|
mint' = endpoint @"mint" >>= mint
|
|
|
|
mkSchemaDefinitions ''SignedSchema
|
|
|
|
mkKnownCurrencies []
|
|
|
|
test :: IO ()
|
|
test = runEmulatorTraceIO $ do
|
|
let tn = "ABC"
|
|
deadline = slotToBeginPOSIXTime def 10
|
|
h <- activateContractWallet (Wallet 1) endpoints
|
|
callEndpoint @"mint" h $ MintParams
|
|
{ mpTokenName = tn
|
|
, mpDeadline = deadline
|
|
, mpAmount = 555
|
|
}
|
|
void $ Emulator.waitNSlots 15
|
|
callEndpoint @"mint" h $ MintParams
|
|
{ mpTokenName = tn
|
|
, mpDeadline = deadline
|
|
, mpAmount = 555
|
|
}
|
|
void $ Emulator.waitNSlots 1
|