added 'Signed'

This commit is contained in:
Lars Brünjes 2021-05-03 21:20:42 +02:00
parent e7a7e51a2b
commit 63476046a2
No known key found for this signature in database
GPG key ID: B488B9045DC1A087
3 changed files with 99 additions and 4 deletions

View file

@ -11,6 +11,7 @@ License-files: LICENSE
library
hs-source-dirs: src
exposed-modules: Week05.Free
, Week05.Signed
build-depends: aeson
, base ^>=4.14.1.0
, containers

View file

@ -32,12 +32,12 @@ import Playground.Types (KnownCurrency (..))
import Text.Printf (printf)
import Wallet.Emulator.Wallet
{-# INLINABLE mkValidator #-}
mkValidator :: ScriptContext -> Bool
mkValidator _ = True
{-# INLINABLE mkPolicy #-}
mkPolicy :: ScriptContext -> Bool
mkPolicy _ = True
policy :: Scripts.MonetaryPolicy
policy = mkMonetaryPolicyScript $$(PlutusTx.compile [|| Scripts.wrapMonetaryPolicy mkValidator ||])
policy = mkMonetaryPolicyScript $$(PlutusTx.compile [|| Scripts.wrapMonetaryPolicy mkPolicy ||])
curSymbol :: CurrencySymbol
curSymbol = scriptCurrencySymbol policy

View file

@ -0,0 +1,94 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Week05.Signed where
import Control.Monad hiding (fmap)
import Control.Monad.Freer.Extras as Extras
import Data.Aeson (ToJSON, FromJSON)
import Data.Text (Text)
import Data.Void (Void)
import GHC.Generics (Generic)
import Plutus.Contract as Contract hiding (when)
import Plutus.Trace.Emulator as Emulator
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 Playground.Contract (printJson, printSchemas, ensureKnownCurrencies, stage, ToSchema)
import Playground.TH (mkKnownCurrencies, mkSchemaDefinitions)
import Playground.Types (KnownCurrency (..))
import Text.Printf (printf)
import Wallet.Emulator.Wallet
{-# INLINABLE mkPolicy #-}
mkPolicy :: PubKeyHash -> ScriptContext -> Bool
mkPolicy pkh ctx = txSignedBy (scriptContextTxInfo ctx) pkh
policy :: PubKeyHash -> Scripts.MonetaryPolicy
policy pkh = mkMonetaryPolicyScript $
$$(PlutusTx.compile [|| Scripts.wrapMonetaryPolicy . mkPolicy ||])
`PlutusTx.applyCode`
PlutusTx.liftCode pkh
curSymbol :: PubKeyHash -> CurrencySymbol
curSymbol = scriptCurrencySymbol . policy
data MintParams = MintParams
{ mpTokenName :: !TokenName
, mpAmount :: !Integer
} deriving (Generic, ToJSON, FromJSON, ToSchema)
type SignedSchema =
BlockchainActions
.\/ Endpoint "mint" MintParams
mint :: (HasBlockchainActions s, AsContractError e) => MintParams -> Contract w s e ()
mint mp = do
pkh <- pubKeyHash <$> Contract.ownPubKey
let val = Value.singleton (curSymbol pkh) (mpTokenName mp) (mpAmount mp)
lookups = Constraints.monetaryPolicy $ policy pkh
tx = Constraints.mustForgeValue val
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"
h1 <- activateContractWallet (Wallet 1) endpoints
h2 <- activateContractWallet (Wallet 2) endpoints
callEndpoint @"mint" h1 $ MintParams
{ mpTokenName = tn
, mpAmount = 555
}
callEndpoint @"mint" h2 $ MintParams
{ mpTokenName = tn
, mpAmount = 444
}
void $ Emulator.waitNSlots 1
callEndpoint @"mint" h1 $ MintParams
{ mpTokenName = tn
, mpAmount = -222
}
void $ Emulator.waitNSlots 1