Skip to content
Permalink
Browse files

Forge arbitrary number of tokens

  • Loading branch information...
j-mueller committed Apr 14, 2019
1 parent ac3c110 commit bad966d3a9ee5a817b44d41de2e644fd2289e533
@@ -22,6 +22,7 @@ library
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
@@ -58,6 +59,7 @@ test-suite plutus-use-cases-test
Spec.Future
Spec.Game
Spec.MultiSig
Spec.Size
Spec.Vesting
default-language: Haskell2010
ghc-options: -Wall -Wnoncanonical-monad-instances
@@ -13,6 +13,7 @@ module Language.PlutusTx.Coordination.Contracts.Currency(
) 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)
@@ -22,48 +23,37 @@ 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 Ledger.Validation (TxHash)
import qualified Ledger.Validation as V
import qualified Ledger.Value.TH as Value
import Ledger as Ledger hiding (to)
import Ledger.Value (TokenName, Value)
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

data Currency = Currency
{ curRefTransactionOutput :: (TxHash, Int)
-- ^ Transaction input that must be spent when
-- the currency is forged.
, curRefAmount :: Int
-- ^ How much of the currency can be forged
, curRefTokenName :: TokenName
-- ^ Token name
}

P.makeLift ''Currency

mkCurrency :: TxOutRef -> Int -> String -> Currency
mkCurrency (TxOutRefOf h i) amt n =
mkCurrency :: TxOutRef -> [(String, Int)] -> Currency
mkCurrency (TxOutRefOf h i) amts =
Currency
{ curRefTransactionOutput = (V.plcTxHash h, i)
, curRefAmount = amt
, curRefTokenName = fromString n
, 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 (Currency (refHash, refIdx) amt token) () () p =
validate c@(Currency (refHash, refIdx) _) () () p =
let
-- see note [Obtaining the currency symbol]
ownSymbol = $$(V.ownCurrencySymbol) p

forged = $$(V.valueForged) p
expected = $$(Value.singleton) ownSymbol token amt
expected = $$currencyValue ownSymbol c


-- True if the pending transaction forges the amount of
-- currency that we expect
@@ -104,16 +94,14 @@ forgedValue cur =
let
-- see note [Obtaining the currency symbol]
a = plcCurrencySymbol (Ledger.scriptAddress (curValidator cur))

t = curRefTokenName cur
i = curRefAmount cur
in
$$(Value.singleton) a t i
$$currencyValue a cur

-- | @forge c n@ forges @n@ units of a currency with one type of token called
-- @c@ and pays them to a public key address owned by the wallet.
forge :: (WalletAPI m, WalletDiagnostics m) => String -> Int -> m Currency
forge nm amount = do
-- | @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
@@ -126,7 +114,7 @@ forge nm amount = do
let

-- With that we can define the currency
theCurrency = mkCurrency (txInRef refTxIn) amount nm
theCurrency = mkCurrency (txInRef refTxIn) amounts
curAddr = Ledger.scriptAddress (curValidator theCurrency)
forgedVal = forgedValue theCurrency
oneOrMore = WAPI.intervalFrom $ Ada.adaValueOf 1
@@ -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'
||]
@@ -7,12 +7,12 @@
module Spec.Crowdfunding(tests) where

import Control.Monad (void)
import Control.Monad.IO.Class
import Data.Either (isRight)
import Data.Foldable (traverse_)
import qualified Data.Map as Map
import Hedgehog (Property, forAll, property)
import qualified Hedgehog
import qualified Spec.Size as Size
import Test.Tasty
import Test.Tasty.Hedgehog (testProperty)
import qualified Test.Tasty.HUnit as HUnit
@@ -41,17 +41,9 @@ tests = testGroup "crowdfunding" [
testProperty "cannot collect money too late" cantCollectLate,
testProperty "cannot collect unless notified" cantCollectUnlessNotified,
testProperty "can claim a refund" canRefund,
HUnit.testCase "script size is reasonable" size
HUnit.testCase "script size is reasonable" (Size.reasonable (CF.contributionScript (cfCampaign scenario1)) 50000)
]

size :: HUnit.Assertion
size = do
let Ledger.ValidatorScript s = CF.contributionScript (cfCampaign scenario1)
let sz = Ledger.scriptSize s
-- so the actual size is visible in the log
liftIO $ putStrLn ("Script size: " ++ show sz)
HUnit.assertBool "script too big" (sz <= 45000)

-- | Make a contribution to the campaign from a wallet. Returns the reference
-- to the transaction output that is locked by the campaign's validator
-- script (and can be collected by the campaign owner)
@@ -1,14 +1,15 @@
{-# LANGUAGE FlexibleContexts #-}
module Spec.Currency(tests) where

import Control.Monad (void, when)
import Control.Monad (void)
import Control.Monad.Except
import Data.Either (isLeft, isRight)
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Spec.Size as Size
import Test.Tasty
import qualified Test.Tasty.HUnit as HUnit

import Language.PlutusTx.Coordination.Contracts.Currency (Currency)
import qualified Language.PlutusTx.Coordination.Contracts.Currency as Cur
import qualified Ledger.Ada as Ada
import Ledger.Value (Value)
@@ -19,26 +20,29 @@ tests = HUnit.testCaseSteps "forge a simple currency" $ \step -> do
let initialState = EM.emulatorStateInitialDist (Map.singleton (EM.walletPubKey w1) initialVal)
(result, st) = EM.runEmulator initialState runForge

when (isLeft result) $ step (show st)

HUnit.assertBool "own funds not equal" (isRight result)
case result of
Left err -> do
step (show st)
step (show err)
HUnit.assertFailure "own funds not equal"
Right cur ->
Size.reasonable (Cur.curValidator cur) 50000

initialVal :: Value
initialVal = Ada.adaValueOf 10

w1 :: EM.Wallet
w1 = EM.Wallet 1

runForge :: (EM.MonadEmulator m) => m ()
runForge :: (EM.MonadEmulator m) => m Currency
runForge = do
let
processAndNotify = void (EM.addBlocksAndNotify [w1] 1)
amount = 1000 -- how much of the currency to forge
currencyName = "my token"
amounts = [("my currency", 1000), ("my token", 1)]

(r, _) <- EM.processEmulated $ do
processAndNotify
cur <- EM.runWalletAction w1 (Cur.forge currencyName amount)
cur <- EM.runWalletAction w1 (Cur.forge amounts)
processAndNotify
processAndNotify
processAndNotify
@@ -48,3 +52,5 @@ runForge = do
c <- either (throwError . EM.AssertionError . T.pack . show) pure r
EM.processEmulated $
EM.assertOwnFundsEq w1 (initialVal <> Cur.forgedValue c)

pure c
@@ -3,12 +3,12 @@
module Spec.Future(tests) where

import Control.Monad (void)
import Control.Monad.IO.Class
import Data.Either (isRight)
import Data.Foldable (traverse_)
import qualified Data.Map as Map
import Hedgehog (Property, forAll, property)
import qualified Hedgehog
import qualified Spec.Size as Size
import Test.Tasty
import Test.Tasty.Hedgehog (testProperty)
import qualified Test.Tasty.HUnit as HUnit
@@ -40,17 +40,9 @@ tests = testGroup "futures" [
testProperty "close the position" settle,
testProperty "close early if margin payment was missed" settleEarly,
testProperty "increase the margin" increaseMargin,
HUnit.testCase "script size is reasonable" size
HUnit.testCase "script size is reasonable" (Size.reasonable (F.validatorScript contract) 50000)
]

size :: HUnit.Assertion
size = do
let Ledger.ValidatorScript s = F.validatorScript contract
let sz = Ledger.scriptSize s
-- so the actual size is visible in the log
liftIO $ putStrLn ("Script size: " ++ show sz)
HUnit.assertBool "script too big" (sz <= 50000)

init :: Wallet -> Trace MockWallet Ledger.TxOutRef
init w = outp <$> walletAction w (F.initialise (walletPubKey wallet1) (walletPubKey wallet2) contract) where
outp = snd . head . filter (Ledger.isPayToScriptOut . fst) . Ledger.txOutRefs . head
@@ -1,13 +1,13 @@
module Spec.Game(tests) where

import Control.Monad (void)
import Control.Monad.IO.Class
import Data.Either (isRight)
import Data.Foldable (traverse_)
import qualified Data.Map as Map

import Hedgehog (Property, forAll, property)
import qualified Hedgehog
import qualified Spec.Size as Size
import Test.Tasty
import Test.Tasty.Hedgehog (testProperty)
import qualified Test.Tasty.HUnit as HUnit
@@ -29,17 +29,9 @@ tests = testGroup "game" [
testProperty "lock" lockProp,
testProperty "guess right" guessRightProp,
testProperty "guess wrong" guessWrongProp,
HUnit.testCase "script size is reasonable" size
HUnit.testCase "script size is reasonable" (Size.reasonable gameValidator 25000)
]

size :: HUnit.Assertion
size = do
let Ledger.ValidatorScript s = gameValidator
let sz = Ledger.scriptSize s
-- so the actual size is visible in the log
liftIO $ putStrLn ("Script size: " ++ show sz)
HUnit.assertBool "script too big" (sz <= 25000)

lockProp :: Property
lockProp = checkTrace $ do
lockFunds
@@ -0,0 +1,17 @@
module Spec.Size(reasonable) where

import Control.Monad.IO.Class (MonadIO (liftIO))
import qualified Test.Tasty.HUnit as HUnit

import Ledger (ValidatorScript)
import qualified Ledger

-- | Assert that the size of a 'ValidatorScript' is below
-- the maximum.
reasonable :: ValidatorScript -> Integer -> HUnit.Assertion
reasonable (Ledger.ValidatorScript s) maxSize = do
let sz = Ledger.scriptSize s
msg = "Script too big! Max. size: " <> show maxSize <> ". Actual size: " <> show sz
-- so the actual size is visible in the log
liftIO $ putStrLn ("Script size: " ++ show sz)
HUnit.assertBool msg (sz <= maxSize)
@@ -7,6 +7,7 @@ module Ledger.Map(
, singleton
, empty
, fromList
, toList
, keys
, map
, lookup
@@ -49,9 +50,14 @@ empty = $$(TH.empty)
these :: (a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these = $$(TH.these)

-- | See 'Ledger.Map.TH.fromList'
fromList :: [(k, v)] -> Map k v
fromList = $$(TH.fromList)

-- | See 'Ledger.Mpa.TH.keys'.
-- | See 'Ledger.Map.TH.toList'
toList :: Map k v -> [(k, v)]
toList = $$(TH.toList)

-- | See 'Ledger.Map.TH.keys'.
keys :: Map k v -> [k]
keys = $$(TH.keys)
@@ -15,6 +15,7 @@ module Ledger.Map.TH(
, singleton
, empty
, fromList
, toList
, keys
, map
, lookup
@@ -53,6 +54,9 @@ instance (FromJSON v, FromJSON k) => FromJSON (Map k v) where
fromList :: Q (TExp ([(k, v)] -> Map k v))
fromList = [|| Map ||]

toList :: Q (TExp (Map k v -> [(k, v)]))
toList = [|| \(Map l) -> l ||]

-- | Apply a function to the values of a 'Map'.
map :: Q (TExp ((v -> w) -> Map k v -> Map k w))
map = [||

0 comments on commit bad966d

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