Skip to content
Permalink
Browse files

Merge pull request #891 from input-output-hk/j-mueller/multi-currency-3

use-cases: Add currency contract
  • Loading branch information...
michaelpj committed Apr 14, 2019
2 parents f7420c3 + bad966d commit 729c041209d14a509218ee775861fd9b75e0239c
@@ -93,7 +93,7 @@ toSimpleArgumentSchemaSpec =
[ ( "unMap"
, SimpleArraySchema
(SimpleTupleSchema
( SimpleHexSchema
( SimpleStringSchema
, SimpleIntSchema)))
])))
])
@@ -169,7 +169,7 @@ vestingSpec =
[ ( "unMap"
, SimpleArraySchema
(SimpleTupleSchema
( SimpleHexSchema
( SimpleStringSchema
, SimpleIntSchema)))
])))
])
@@ -253,7 +253,7 @@ simpleTraceDist = EM.fundsDistribution $ snd $ runTrace simpleTrace
{- |
>>> simpleTraceDist
fromList [(Wallet {getWallet = 1},Value {getValue = Map {unMap = [(,Map {unMap = [(SizedByteString {unSizedByteString = ""},900)]})]}}),(Wallet {getWallet = 2},Value {getValue = Map {unMap = [(,Map {unMap = [(SizedByteString {unSizedByteString = ""},1100)]})]}})]
fromList [(Wallet {getWallet = 1},Value {getValue = Map {unMap = [(,Map {unMap = [(,900)]})]}}),(Wallet {getWallet = 2},Value {getValue = Map {unMap = [(,Map {unMap = [(,1100)]})]}})]
'simpleTraceDist' shows that our transaction was successful: Wallet 1 now
owns 900 Ada (the currency identified by )
@@ -292,7 +292,7 @@ gameSuccess = do
The final distribution after 'gameSuccess' looks as we would expect:
>>> EM.fundsDistribution $ snd $ runTrace simpleTrace
fromList [(Wallet {getWallet = 1},Value {getValue = Map {unMap = [(,Map {unMap = [(SizedByteString {unSizedByteString = ""},900)]})]}}),(Wallet {getWallet = 2},Value {getValue = Map {unMap = [(,Map {unMap = [(SizedByteString {unSizedByteString = ""},1100)]})]}})]
fromList [(Wallet {getWallet = 1},Value {getValue = Map {unMap = [(,Map {unMap = [(,900)]})]}}),(Wallet {getWallet = 2},Value {getValue = Map {unMap = [(,Map {unMap = [(,1100)]})]}})]
-}

@@ -337,7 +337,7 @@ vestingSuccess = do
functions `runTraceDist` and `runTraceLog` from `Ledger.ExUtil`
>>> import Tutorial.ExUtil
>>> runTraceDist vestingSuccess
fromList [(Wallet {getWallet = 1},Value {getValue = Map {unMap = [(,Map {unMap = [(SizedByteString {unSizedByteString = ""},1010)]})]}}),(Wallet {getWallet = 2},Value {getValue = Map {unMap = [(,Map {unMap = [(SizedByteString {unSizedByteString = ""},940)]})]}}),(Wallet {getWallet = 3},Value {getValue = Map {unMap = [(,Map {unMap = [(SizedByteString {unSizedByteString = ""},1000)]})]}})]
fromList [(Wallet {getWallet = 1},Value {getValue = Map {unMap = [(,Map {unMap = [(,1010)]})]}}),(Wallet {getWallet = 2},Value {getValue = Map {unMap = [(,Map {unMap = [(,940)]})]}}),(Wallet {getWallet = 3},Value {getValue = Map {unMap = [(,Map {unMap = [(,1000)]})]}})]
E9. Write traces similar to `vestingSuccess` that
@@ -5,6 +5,8 @@ module Language.PlutusTx.Prelude (
toPlutusString,
trace,
traceH,
traceIfTrueH,
traceIfFalseH,
-- * Error
error,
-- * Boolean operators
@@ -43,6 +43,14 @@ trace = [||
traceH :: Q (TExp (String -> a -> a))
traceH = [|| \str a -> $$(trace) ($$(toPlutusString) str) a||]

-- | Emit the given Haskell 'String' only if the argument evaluates to 'False'.
traceIfFalseH :: Q (TExp (String -> Bool -> Bool))
traceIfFalseH = [|| \str a -> if a then True else $$traceH str False ||]

-- | Emit the given Haskell 'String' only if the argument evaluates to 'True'.
traceIfTrueH :: Q (TExp (String -> Bool -> Bool))
traceIfTrueH = [|| \str a -> if a then $$traceH str True else False ||]

-- | Logical AND
--
-- >>> $$([|| $$(and) True False ||])
@@ -21,9 +21,12 @@ library
exposed-modules:
Language.PlutusTx.Coordination.Contracts
Language.PlutusTx.Coordination.Contracts.CrowdFunding
Language.PlutusTx.Coordination.Contracts.Currency
Language.PlutusTx.Coordination.Contracts.Currency.Stage0
Language.PlutusTx.Coordination.Contracts.Future
Language.PlutusTx.Coordination.Contracts.Game
Language.PlutusTx.Coordination.Contracts.MultiSig
Language.PlutusTx.Coordination.Contracts.PubKey
Language.PlutusTx.Coordination.Contracts.Vesting
Language.PlutusTx.Coordination.Contracts.Swap
hs-source-dirs: src
@@ -43,17 +46,20 @@ library
template-haskell -any,
plutus-tx -any,
wallet-api -any,
lens -any
lens -any,
text -any

test-suite plutus-use-cases-test
type: exitcode-stdio-1.0
main-is: Spec.hs
hs-source-dirs: test
other-modules:
Spec.Crowdfunding
Spec.Currency
Spec.Future
Spec.Game
Spec.MultiSig
Spec.Size
Spec.Vesting
default-language: Haskell2010
ghc-options: -Wall -Wnoncanonical-monad-instances
@@ -94,13 +94,13 @@ contribute cmp adaAmount = do
tx <- payToScript range (campaignAddress cmp) value ds
logMsg "Submitted contribution"

register (refundTrigger cmp) (refund (Ledger.hashTx tx) cmp)
W.register (refundTrigger cmp) (refund (Ledger.hashTx tx) cmp)
logMsg "Registered refund trigger"

-- | Register a [[EventHandler]] to collect all the funds of a campaign
--
collect :: (WalletAPI m, WalletDiagnostics m) => Campaign -> m ()
collect cmp = register (collectFundsTrigger cmp) $ EventHandler $ \_ -> do
collect cmp = W.register (collectFundsTrigger cmp) $ EventHandler $ \_ -> do
logMsg "Collecting funds"
am <- watchedAddresses
let scr = contributionScript cmp
@@ -0,0 +1,164 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -O0 #-}
-- | Implements a custom currency with a monetary policy that allows
-- the forging of a fixed amount of units.
module Language.PlutusTx.Coordination.Contracts.Currency(
Currency(..)
, curValidator
-- * Actions etc
, forge
, forgedValue
) where

import Control.Lens ((^.), at, to)
import Data.Bifunctor (Bifunctor(first))
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.String (IsString(fromString))
import qualified Data.Text as Text

import qualified Language.PlutusTx as P

import qualified Ledger.Ada as Ada
import qualified Ledger.Map as LMap
import Ledger.Scripts (ValidatorScript(..))
import qualified Ledger.Validation as V
import qualified Ledger.Value.TH as Value
import Ledger as Ledger hiding (to)
import Ledger.Value (Value)
import Wallet.API as WAPI

import qualified Language.PlutusTx.Coordination.Contracts.PubKey as PK
import Language.PlutusTx.Coordination.Contracts.Currency.Stage0 as Stage0

mkCurrency :: TxOutRef -> [(String, Int)] -> Currency
mkCurrency (TxOutRefOf h i) amts =
Currency
{ curRefTransactionOutput = (V.plcTxHash h, i)
, curAmounts = LMap.fromList (fmap (first fromString) amts)
}

curValidator :: Currency -> ValidatorScript
curValidator cur =
ValidatorScript (Ledger.applyScript mkValidator (Ledger.lifted cur)) where
mkValidator = Ledger.fromCompiledCode ($$(P.compile [||
let validate :: Currency -> () -> () -> V.PendingTx -> ()
validate c@(Currency (refHash, refIdx) _) () () p =
let
-- see note [Obtaining the currency symbol]
ownSymbol = $$(V.ownCurrencySymbol) p

forged = $$(V.valueForged) p
expected = $$currencyValue ownSymbol c


-- True if the pending transaction forges the amount of
-- currency that we expect
forgeOK =
let v = $$(Value.eq) expected forged
in $$(P.traceIfFalseH) "Value forged different from expected" v

-- True if the pending transaction spends the output
-- identified by @(refHash, refIdx)@
txOutputSpent =
let v = $$(V.spendsOutput) p refHash refIdx
in $$(P.traceIfFalseH) "Pending transaction does not spend the designated transaction output" v

in
if $$(P.and) forgeOK txOutputSpent
then ()
else $$(P.error) ($$(P.traceH) "Invalid forge" ())
in
validate
||]))

{- note [Obtaining the currency symbol]
The currency symbol is the address (hash) of the validator. That is why
we can use 'Ledger.scriptAddress' here to get the symbol in off-chain code,
for example in 'forgedValue'.
Inside the validator script (on-chain) we can't use 'Ledger.scriptAddress',
because at that point we don't know the hash of the script yet. That
is why we use 'V.ownCurrencySymbol', which obtains the hash from the
'PendingTx' value.
-}

-- | The 'Value' forged by the 'curValidator' contract
forgedValue :: Currency -> Value
forgedValue cur =
let
-- see note [Obtaining the currency symbol]
a = plcCurrencySymbol (Ledger.scriptAddress (curValidator cur))
in
$$currencyValue a cur

-- | @forge [(n1, c1), ..., (n_k, c_k)]@ creates a new currency with
-- @k@ token names, forging @c_i@ units of each token @n_i@.
-- If @k == 0@ then no value is forged.
forge :: (WalletAPI m, WalletDiagnostics m) => [(String, Int)] -> m Currency
forge amounts = do
pk <- WAPI.ownPubKey

-- 1. We need to create the reference transaction output using the
-- 'PublicKey' contract. That way we get an output that behaves
-- like a normal public key output, but is not selected by the
-- wallet during coin selection. This ensures that the output still
-- exists when we spend it in our forging transaction.
(refAddr, refTxIn) <- PK.lock pk (Ada.adaValueOf 1)

let

-- With that we can define the currency
theCurrency = mkCurrency (txInRef refTxIn) amounts
curAddr = Ledger.scriptAddress (curValidator theCurrency)
forgedVal = forgedValue theCurrency
oneOrMore = WAPI.intervalFrom $ Ada.adaValueOf 1

-- trg1 fires when 'refTxIn' can be spent by our forging transaction
trg1 = fundsAtAddressT refAddr oneOrMore

-- trg2 fires when the pay-to-script output locked by 'curValidator'
-- is ready to be spent.
trg2 = fundsAtAddressT curAddr oneOrMore

-- The 'forge_' action creates a transaction that spends the contract
-- output, forging the currency in the process.
forge_ :: (WalletAPI m, WalletDiagnostics m) => m ()
forge_ = do
ownOutput <- WAPI.ownPubKeyTxOut (forgedVal <> Ada.adaValueOf 2)
am <- WAPI.watchedAddresses

let inputs' = am ^. at curAddr . to (Map.toList . fromMaybe Map.empty)
con (r, _) = scriptTxIn r (curValidator theCurrency) (RedeemerScript $ Ledger.lifted ())
ins = con <$> inputs'

let tx = Ledger.Tx
{ txInputs = Set.fromList (refTxIn:ins)
, txOutputs = [ownOutput]
, txForge = forgedVal
, txFee = Ada.zero
, txValidRange = defaultSlotRange
, txSignatures = Map.empty
}

WAPI.logMsg $ Text.pack $ "Forging transaction: " <> show (Ledger.hashTx tx)
WAPI.signTxAndSubmit_ tx

-- 2. We start watching the contract address, ready to forge
-- our currency once the monetary policy script has been
-- placed on the chain.
registerOnce trg2 (EventHandler $ const forge_)

-- 3. When trg1 fires we submit a transaction that creates a
-- pay-to-script output locked by the monetary policy
registerOnce trg1 (EventHandler $ const $ do
payToScript_ defaultSlotRange curAddr (Ada.adaValueOf 1) (DataScript $ Ledger.lifted ()))

-- Return the currency definition so that we can use the symbol
-- in other places
pure theCurrency
@@ -0,0 +1,35 @@
{-# LANGUAGE TemplateHaskell #-}
module Language.PlutusTx.Coordination.Contracts.Currency.Stage0 where

import qualified Language.PlutusTx as P

import Ledger.Validation (TxHash)
import qualified Ledger.Map as LMap
import qualified Ledger.Map.TH as LMap.TH
import Ledger.Value (CurrencySymbol, TokenName, Value)
import qualified Ledger.Value.TH as Value.TH

import Language.Haskell.TH (Q, TExp)

data Currency = Currency
{ curRefTransactionOutput :: (TxHash, Int)
-- ^ Transaction input that must be spent when
-- the currency is forged.
, curAmounts :: LMap.Map TokenName Int
-- ^ How many units of each 'TokenName' are to
-- be forged.
}

P.makeLift ''Currency

currencyValue :: Q (TExp (CurrencySymbol -> Currency -> Value))
currencyValue = [||
let currencyValue' :: CurrencySymbol -> Currency -> Value
currencyValue' s c =
let
Currency _ amts = c
values = $$(P.map) (\(tn, i) -> ($$(Value.TH.singleton) s tn i)) ($$(LMap.TH.toList) amts)
in $$(P.foldr) $$(Value.TH.plus) $$(Value.TH.zero) values

in currencyValue'
||]
@@ -0,0 +1,59 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
-- | A "pay-to-pubkey" transaction output implemented as a Plutus
-- contract. This is useful if you need something that behaves like
-- a pay-to-pubkey output, but is not (easily) identified by wallets
-- as one.
module Language.PlutusTx.Coordination.Contracts.PubKey(lock) where

import Data.Maybe (listToMaybe)
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified Language.PlutusTx as P
import Ledger as Ledger hiding (initialise, to)
import Ledger.Validation as V
import Wallet.API as WAPI

pkValidator :: PubKey -> ValidatorScript
pkValidator pk =
ValidatorScript (Ledger.applyScript mkValidator (Ledger.lifted pk)) where
mkValidator =
Ledger.fromCompiledCode ($$(P.compile [||
let
validate :: PubKey -> () -> () -> PendingTx -> ()
validate pk' () () p =
if $$(V.txSignedBy) p pk'
then ()
else $$(P.error) ($$(P.traceH) "Required signature not present!" ())
in validate
||]))

-- | Lock some funds in a 'PayToPubKey' contract, returning the output's address
-- and a 'TxIn' transaction input that can spend it.
lock :: (WalletAPI m, WalletDiagnostics m) => PubKey -> Value -> m (Address, TxIn)
lock pk vl = getRef =<< payToScript defaultSlotRange addr vl pkDataScript where
addr = Ledger.scriptAddress (pkValidator pk)
pkDataScript = DataScript $ Ledger.lifted ()
pkRedeemer = RedeemerScript $ Ledger.lifted ()

getRef tx = do
let scriptOuts = listToMaybe
$ fmap fst
$ filter ((==) addr . txOutAddress . snd)
$ Map.toList (unspentOutputsTx tx)

txin <- case scriptOuts of
Nothing -> throwOtherError
$ "transaction did not contain script output"
<> "for public key '"
<> Text.pack (show pk)
<> "'"
Just o -> pure (scriptTxIn o (pkValidator pk) pkRedeemer)

pure (addr, txin)
@@ -2,6 +2,7 @@
module Main(main) where

import qualified Spec.Crowdfunding
import qualified Spec.Currency
import qualified Spec.Future
import qualified Spec.Game
import qualified Spec.MultiSig
@@ -25,5 +26,6 @@ tests = localOption limit $ testGroup "use cases" [
Spec.Vesting.tests,
Spec.Future.tests,
Spec.Game.tests,
Spec.MultiSig.tests
Spec.MultiSig.tests,
Spec.Currency.tests
]
Oops, something went wrong.

0 comments on commit 729c041

Please sign in to comment.
You can’t perform that action at this time.