{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Test.Cardano.Ledger.Mary.Examples.MultiAssets
-- Description : Multi-Assets Examples
--
-- Examples demonstrating the use of multi-assets.
module Test.Cardano.Ledger.Mary.Examples.MultiAssets (
  multiAssetsExample,
)
where

import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure (..))
import Cardano.Ledger.Allegra.Scripts (
  Timelock (..),
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.BaseTypes (StrictMaybe (..))
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.Mary (MaryEra)
import Cardano.Ledger.Mary.Core
import Cardano.Ledger.Mary.Value (
  AssetName (..),
  MaryValue (..),
  MultiAsset (..),
  PolicyID (..),
 )
import Cardano.Ledger.Shelley.API (LedgerEnv (..), ShelleyLEDGER)
import Cardano.Ledger.Shelley.LedgerState (AccountState (..))
import Cardano.Ledger.Shelley.Rules (ShelleyLedgerPredFailure (..), ShelleyUtxowPredFailure (..))
import Cardano.Ledger.Shelley.Scripts (
  pattern RequireAllOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.Tx (ShelleyTx (..))
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.Shelley.TxWits (addrWits)
import Cardano.Ledger.Slot (SlotNo (..))
import Cardano.Ledger.TxIn (TxId, TxIn (..), mkTxInPartial)
import Cardano.Ledger.UTxO (UTxO (..))
import Cardano.Ledger.Val ((<+>), (<->))
import qualified Cardano.Ledger.Val as Val
import Control.Exception (ErrorCall (ErrorCall), evaluate, try)
import Control.State.Transition.Extended (PredicateFailure)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import GHC.Exts (fromString)
import Lens.Micro
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkWitnessesVKey)
import Test.Cardano.Ledger.Mary.Examples (testMaryNoDelegLEDGER)
import qualified Test.Cardano.Ledger.Mary.Examples.Cast as Cast
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, assertFailure, testCase)

------------------------------
-- Set Up the Initial State --
------------------------------

aliceInitCoin :: Coin
aliceInitCoin :: Coin
aliceInitCoin = Integer -> Coin
Coin forall a b. (a -> b) -> a -> b
$ Integer
10_000_000_000_000_000

bobInitCoin :: Coin
bobInitCoin :: Coin
bobInitCoin = Integer -> Coin
Coin forall a b. (a -> b) -> a -> b
$ Integer
1_000_000_000_000_000

unboundedInterval :: ValidityInterval
unboundedInterval :: ValidityInterval
unboundedInterval = StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval forall a. StrictMaybe a
SNothing forall a. StrictMaybe a
SNothing

bootstrapTxId :: TxId
bootstrapTxId :: TxId
bootstrapTxId = forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txb
  where
    txb :: TxBody MaryEra
    txb :: TxBody MaryEra
txb = forall era. EraTxBody era => TxBody era
mkBasicTxBody

initUTxO :: UTxO MaryEra
initUTxO :: UTxO MaryEra
initUTxO =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
0, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr (forall t s. Inject t s => t -> s
Val.inject Coin
aliceInitCoin))
      , (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
1, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr (forall t s. Inject t s => t -> s
Val.inject Coin
bobInitCoin))
      ]

pp :: PParams MaryEra
pp :: PParams MaryEra
pp =
  forall era. EraPParams era => PParams era
emptyPParams
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
0
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeBL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1
    forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxTxSizeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
16384
    forall a b. a -> (a -> b) -> b
& forall era.
(EraPParams era, ProtVerAtMost era 4) =>
Lens' (PParams era) Coin
ppMinUTxOValueL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
100

ledgerEnv :: SlotNo -> LedgerEnv MaryEra
ledgerEnv :: SlotNo -> LedgerEnv MaryEra
ledgerEnv SlotNo
s = forall era.
SlotNo
-> Maybe EpochNo
-> TxIx
-> PParams era
-> AccountState
-> Bool
-> LedgerEnv era
LedgerEnv SlotNo
s forall a. Maybe a
Nothing forall a. Bounded a => a
minBound PParams MaryEra
pp (Coin -> Coin -> AccountState
AccountState (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0)) Bool
False

feeEx :: Coin
feeEx :: Coin
feeEx = Integer -> Coin
Coin Integer
3

-- These examples do not use several of the transaction components,
-- so we can simplify building them.
makeMaryTxBody ::
  [TxIn] ->
  [ShelleyTxOut MaryEra] ->
  ValidityInterval ->
  MultiAsset ->
  TxBody MaryEra
makeMaryTxBody :: [TxIn]
-> [ShelleyTxOut MaryEra]
-> ValidityInterval
-> MultiAsset
-> TxBody MaryEra
makeMaryTxBody [TxIn]
ins [ShelleyTxOut MaryEra]
outs ValidityInterval
interval MultiAsset
minted =
  forall era. EraTxBody era => TxBody era
mkBasicTxBody
    forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList [TxIn]
ins
    forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. [a] -> StrictSeq a
StrictSeq.fromList [ShelleyTxOut MaryEra]
outs
    forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
feeEx
    forall a b. a -> (a -> b) -> b
& forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
vldtTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ ValidityInterval
interval
    forall a b. a -> (a -> b) -> b
& forall era. MaryEraTxBody era => Lens' (TxBody era) MultiAsset
mintTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ MultiAsset
minted

policyFailure ::
  PolicyID -> Either (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra))) (UTxO MaryEra)
policyFailure :: PolicyID
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
policyFailure PolicyID
p =
  forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Set ScriptHash -> ShelleyUtxowPredFailure era
ScriptWitnessNotValidatingUTXOW forall a b. (a -> b) -> a -> b
$ forall a. a -> Set a
Set.singleton (PolicyID -> ScriptHash
policyID PolicyID
p)

outTooBigFailure ::
  ShelleyTxOut MaryEra -> Either (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra))) (UTxO MaryEra)
outTooBigFailure :: ShelleyTxOut MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
outTooBigFailure ShelleyTxOut MaryEra
out =
  forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "UTXOW" era)
-> ShelleyLedgerPredFailure era
UtxowFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
PredicateFailure (EraRule "UTXO" era)
-> ShelleyUtxowPredFailure era
UtxoFailure forall a b. (a -> b) -> a -> b
$ forall era. [TxOut era] -> AllegraUtxoPredFailure era
OutputTooBigUTxO [ShelleyTxOut MaryEra
out]

----------------------------------------------------
-- Introduce a new Token Bundle, Purple Tokens
--
-- Variables ending with SimpleExN (for a numeral N)
-- refer to this example.
----------------------------------------------------

-- This is the most lax policy possible, requiring no authorization at all.
purplePolicy :: Timelock MaryEra
purplePolicy :: Timelock MaryEra
purplePolicy = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf (forall a. [a] -> StrictSeq a
StrictSeq.fromList [])

purplePolicyId :: PolicyID
purplePolicyId :: PolicyID
purplePolicyId = ScriptHash -> PolicyID
PolicyID forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @MaryEra Timelock MaryEra
purplePolicy

plum :: AssetName
plum :: AssetName
plum = ShortByteString -> AssetName
AssetName ShortByteString
"plum"

amethyst :: AssetName
amethyst :: AssetName
amethyst = ShortByteString -> AssetName
AssetName ShortByteString
"amethyst"

------------------------
-- Mint Purple Tokens --
------------------------

mintSimpleEx1 :: MultiAsset
mintSimpleEx1 :: MultiAsset
mintSimpleEx1 =
  Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
    forall k a. k -> a -> Map k a
Map.singleton PolicyID
purplePolicyId (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AssetName
plum, Integer
13), (AssetName
amethyst, Integer
2)])

aliceCoinSimpleEx1 :: Coin
aliceCoinSimpleEx1 :: Coin
aliceCoinSimpleEx1 = Coin
aliceInitCoin forall t. Val t => t -> t -> t
<-> Coin
feeEx

tokensSimpleEx1 :: MaryValue
tokensSimpleEx1 :: MaryValue
tokensSimpleEx1 = Coin -> MultiAsset -> MaryValue
MaryValue forall a. Monoid a => a
mempty MultiAsset
mintSimpleEx1 forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
Val.inject Coin
aliceCoinSimpleEx1

-- Mint a purple token bundle, consisting of thirteen plums and two amethysts.
-- Give the bundle to Alice.
txbodySimpleEx1 :: TxBody MaryEra
txbodySimpleEx1 :: TxBody MaryEra
txbodySimpleEx1 =
  [TxIn]
-> [ShelleyTxOut MaryEra]
-> ValidityInterval
-> MultiAsset
-> TxBody MaryEra
makeMaryTxBody
    [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
0]
    [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr MaryValue
tokensSimpleEx1]
    ValidityInterval
unboundedInterval
    MultiAsset
mintSimpleEx1

txSimpleEx1 :: ShelleyTx MaryEra
txSimpleEx1 :: ShelleyTx MaryEra
txSimpleEx1 =
  forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody MaryEra
txbodySimpleEx1
    forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall era. EraTxWits era => TxWits era
mkBasicTxWits forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey 'Witness)
atw forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ScriptHash (Timelock MaryEra)
stw)
  where
    atw :: Set (WitVKey 'Witness)
atw = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody MaryEra
txbodySimpleEx1) [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.alicePay]
    stw :: Map ScriptHash (Timelock MaryEra)
stw = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PolicyID -> ScriptHash
policyID PolicyID
purplePolicyId, Timelock MaryEra
purplePolicy)]

expectedUTxOSimpleEx1 :: UTxO MaryEra
expectedUTxOSimpleEx1 :: UTxO MaryEra
expectedUTxOSimpleEx1 =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodySimpleEx1) Integer
0, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr MaryValue
tokensSimpleEx1)
      , (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
1, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr (forall t s. Inject t s => t -> s
Val.inject Coin
bobInitCoin))
      ]

----------------------------
-- Transfer Purple Tokens --
----------------------------

minUtxoSimpleEx2 :: Coin
minUtxoSimpleEx2 :: Coin
minUtxoSimpleEx2 = Integer -> Coin
Coin Integer
117

aliceCoinsSimpleEx2 :: Coin
aliceCoinsSimpleEx2 :: Coin
aliceCoinsSimpleEx2 = Coin
aliceCoinSimpleEx1 forall t. Val t => t -> t -> t
<-> (Coin
feeEx forall t. Val t => t -> t -> t
<+> Coin
minUtxoSimpleEx2)

aliceTokensSimpleEx2 :: MaryValue
aliceTokensSimpleEx2 :: MaryValue
aliceTokensSimpleEx2 =
  Coin -> MultiAsset -> MaryValue
MaryValue Coin
aliceCoinsSimpleEx2 forall a b. (a -> b) -> a -> b
$
    Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
      forall k a. k -> a -> Map k a
Map.singleton PolicyID
purplePolicyId (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AssetName
plum, Integer
8), (AssetName
amethyst, Integer
2)])

bobTokensSimpleEx2 :: MaryValue
bobTokensSimpleEx2 :: MaryValue
bobTokensSimpleEx2 =
  Coin -> MultiAsset -> MaryValue
MaryValue Coin
minUtxoSimpleEx2 forall a b. (a -> b) -> a -> b
$
    Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
      forall k a. k -> a -> Map k a
Map.singleton PolicyID
purplePolicyId (forall k a. k -> a -> Map k a
Map.singleton AssetName
plum Integer
5)

-- Alice gives five plums to Bob.
txbodySimpleEx2 :: TxBody MaryEra
txbodySimpleEx2 :: TxBody MaryEra
txbodySimpleEx2 =
  [TxIn]
-> [ShelleyTxOut MaryEra]
-> ValidityInterval
-> MultiAsset
-> TxBody MaryEra
makeMaryTxBody
    [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodySimpleEx1) Integer
0]
    [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr MaryValue
aliceTokensSimpleEx2
    , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr MaryValue
bobTokensSimpleEx2
    ]
    ValidityInterval
unboundedInterval
    forall a. Monoid a => a
mempty

txSimpleEx2 :: ShelleyTx MaryEra
txSimpleEx2 :: ShelleyTx MaryEra
txSimpleEx2 =
  forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody MaryEra
txbodySimpleEx2
    forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall era. EraTxWits era => TxWits era
mkBasicTxWits forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey 'Witness)
atw)
  where
    atw :: Set (WitVKey 'Witness)
atw = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody MaryEra
txbodySimpleEx2) [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.alicePay]

expectedUTxOSimpleEx2 :: UTxO MaryEra
expectedUTxOSimpleEx2 :: UTxO MaryEra
expectedUTxOSimpleEx2 =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodySimpleEx2) Integer
0, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr MaryValue
aliceTokensSimpleEx2)
      , (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodySimpleEx2) Integer
1, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr MaryValue
bobTokensSimpleEx2)
      , (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
1, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr (forall t s. Inject t s => t -> s
Val.inject Coin
bobInitCoin))
      ]

------------------------------------------------------------
-- Introduce a new Token Bundle, Tokens With a Time Range
--
-- Variables ending with TimeExN (for a numeral N)
-- refer to this example.
------------------------------------------------------------

beforeStart :: SlotNo
beforeStart :: SlotNo
beforeStart = Word64 -> SlotNo
SlotNo Word64
12

startInterval :: SlotNo
startInterval :: SlotNo
startInterval = Word64 -> SlotNo
SlotNo Word64
13

stopInterval :: SlotNo
stopInterval :: SlotNo
stopInterval = Word64 -> SlotNo
SlotNo Word64
19

afterStop :: SlotNo
afterStop :: SlotNo
afterStop = Word64 -> SlotNo
SlotNo Word64
20

boundedTimePolicy :: Timelock MaryEra
boundedTimePolicy :: Timelock MaryEra
boundedTimePolicy =
  forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf
    ( forall a. [a] -> StrictSeq a
StrictSeq.fromList
        [ forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart SlotNo
startInterval
        , forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeExpire SlotNo
stopInterval
        ]
    )

boundedTimePolicyId :: PolicyID
boundedTimePolicyId :: PolicyID
boundedTimePolicyId = ScriptHash -> PolicyID
PolicyID forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @MaryEra Timelock MaryEra
boundedTimePolicy

tokenTimeEx :: AssetName
tokenTimeEx :: AssetName
tokenTimeEx = ShortByteString -> AssetName
AssetName ShortByteString
"tokenTimeEx"

------------------------------------
-- Mint Bounded Time Range Tokens --
------------------------------------

mintTimeEx1 :: MultiAsset
mintTimeEx1 :: MultiAsset
mintTimeEx1 =
  Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
    forall k a. k -> a -> Map k a
Map.singleton PolicyID
boundedTimePolicyId (forall k a. k -> a -> Map k a
Map.singleton AssetName
tokenTimeEx Integer
1)

aliceCoinsTimeEx1 :: Coin
aliceCoinsTimeEx1 :: Coin
aliceCoinsTimeEx1 = Coin
aliceInitCoin forall t. Val t => t -> t -> t
<-> Coin
feeEx

tokensTimeEx1 :: MaryValue
tokensTimeEx1 :: MaryValue
tokensTimeEx1 = Coin -> MultiAsset -> MaryValue
MaryValue forall a. Monoid a => a
mempty MultiAsset
mintTimeEx1 forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
Val.inject Coin
aliceCoinsTimeEx1

-- Mint tokens
txbodyTimeEx1 :: StrictMaybe SlotNo -> StrictMaybe SlotNo -> TxBody MaryEra
txbodyTimeEx1 :: StrictMaybe SlotNo -> StrictMaybe SlotNo -> TxBody MaryEra
txbodyTimeEx1 StrictMaybe SlotNo
s StrictMaybe SlotNo
e =
  [TxIn]
-> [ShelleyTxOut MaryEra]
-> ValidityInterval
-> MultiAsset
-> TxBody MaryEra
makeMaryTxBody
    [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
0]
    [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr MaryValue
tokensTimeEx1]
    (StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval StrictMaybe SlotNo
s StrictMaybe SlotNo
e)
    MultiAsset
mintTimeEx1

txbodyTimeEx1Valid :: TxBody MaryEra
txbodyTimeEx1Valid :: TxBody MaryEra
txbodyTimeEx1Valid = StrictMaybe SlotNo -> StrictMaybe SlotNo -> TxBody MaryEra
txbodyTimeEx1 (forall a. a -> StrictMaybe a
SJust SlotNo
startInterval) (forall a. a -> StrictMaybe a
SJust SlotNo
stopInterval)

txTimeEx1 :: TxBody MaryEra -> ShelleyTx MaryEra
txTimeEx1 :: TxBody MaryEra -> ShelleyTx MaryEra
txTimeEx1 TxBody MaryEra
txbody =
  forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody MaryEra
txbody
    forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall era. EraTxWits era => TxWits era
mkBasicTxWits forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey 'Witness)
atw forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ScriptHash (Timelock MaryEra)
stw)
  where
    atw :: Set (WitVKey 'Witness)
atw = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody MaryEra
txbody) [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.alicePay]
    stw :: Map ScriptHash (Timelock MaryEra)
stw = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PolicyID -> ScriptHash
policyID PolicyID
boundedTimePolicyId, Timelock MaryEra
boundedTimePolicy)]

txTimeEx1Valid :: ShelleyTx MaryEra
txTimeEx1Valid :: ShelleyTx MaryEra
txTimeEx1Valid = TxBody MaryEra -> ShelleyTx MaryEra
txTimeEx1 TxBody MaryEra
txbodyTimeEx1Valid

txTimeEx1InvalidLHSfixed :: ShelleyTx MaryEra
txTimeEx1InvalidLHSfixed :: ShelleyTx MaryEra
txTimeEx1InvalidLHSfixed = TxBody MaryEra -> ShelleyTx MaryEra
txTimeEx1 forall a b. (a -> b) -> a -> b
$ StrictMaybe SlotNo -> StrictMaybe SlotNo -> TxBody MaryEra
txbodyTimeEx1 (forall a. a -> StrictMaybe a
SJust SlotNo
beforeStart) (forall a. a -> StrictMaybe a
SJust SlotNo
stopInterval)

txTimeEx1InvalidLHSopen :: ShelleyTx MaryEra
txTimeEx1InvalidLHSopen :: ShelleyTx MaryEra
txTimeEx1InvalidLHSopen = TxBody MaryEra -> ShelleyTx MaryEra
txTimeEx1 forall a b. (a -> b) -> a -> b
$ StrictMaybe SlotNo -> StrictMaybe SlotNo -> TxBody MaryEra
txbodyTimeEx1 forall a. StrictMaybe a
SNothing (forall a. a -> StrictMaybe a
SJust SlotNo
stopInterval)

txTimeEx1InvalidRHSfixed :: ShelleyTx MaryEra
txTimeEx1InvalidRHSfixed :: ShelleyTx MaryEra
txTimeEx1InvalidRHSfixed = TxBody MaryEra -> ShelleyTx MaryEra
txTimeEx1 forall a b. (a -> b) -> a -> b
$ StrictMaybe SlotNo -> StrictMaybe SlotNo -> TxBody MaryEra
txbodyTimeEx1 (forall a. a -> StrictMaybe a
SJust SlotNo
startInterval) (forall a. a -> StrictMaybe a
SJust SlotNo
afterStop)

txTimeEx1InvalidRHSopen :: ShelleyTx MaryEra
txTimeEx1InvalidRHSopen :: ShelleyTx MaryEra
txTimeEx1InvalidRHSopen = TxBody MaryEra -> ShelleyTx MaryEra
txTimeEx1 forall a b. (a -> b) -> a -> b
$ StrictMaybe SlotNo -> StrictMaybe SlotNo -> TxBody MaryEra
txbodyTimeEx1 (forall a. a -> StrictMaybe a
SJust SlotNo
startInterval) forall a. StrictMaybe a
SNothing

expectedUTxOTimeEx1 :: UTxO MaryEra
expectedUTxOTimeEx1 :: UTxO MaryEra
expectedUTxOTimeEx1 =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodyTimeEx1Valid) Integer
0, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr MaryValue
tokensTimeEx1)
      , (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
1, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr (forall t s. Inject t s => t -> s
Val.inject Coin
bobInitCoin))
      ]

----------------------------------------
-- Transfer Bounded Time Range Tokens --
----------------------------------------

mintTimeEx2 :: Coin
mintTimeEx2 :: Coin
mintTimeEx2 = Integer -> Coin
Coin Integer
120

bobTokensTimeEx2 :: MaryValue
bobTokensTimeEx2 :: MaryValue
bobTokensTimeEx2 =
  Coin -> MultiAsset -> MaryValue
MaryValue Coin
mintTimeEx2 forall a b. (a -> b) -> a -> b
$
    Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
      forall k a. k -> a -> Map k a
Map.singleton PolicyID
boundedTimePolicyId (forall k a. k -> a -> Map k a
Map.singleton AssetName
tokenTimeEx Integer
1)

aliceCoinsTimeEx2 :: Coin
aliceCoinsTimeEx2 :: Coin
aliceCoinsTimeEx2 = Coin
aliceCoinSimpleEx1 forall t. Val t => t -> t -> t
<-> (Coin
feeEx forall t. Val t => t -> t -> t
<+> Coin
mintTimeEx2)

-- Alice gives one token to Bob
txbodyTimeEx2 :: TxBody MaryEra
txbodyTimeEx2 :: TxBody MaryEra
txbodyTimeEx2 =
  [TxIn]
-> [ShelleyTxOut MaryEra]
-> ValidityInterval
-> MultiAsset
-> TxBody MaryEra
makeMaryTxBody
    [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodyTimeEx1Valid) Integer
0]
    [ forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr (forall t s. Inject t s => t -> s
Val.inject Coin
aliceCoinsTimeEx2)
    , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr MaryValue
bobTokensTimeEx2
    ]
    ValidityInterval
unboundedInterval
    forall a. Monoid a => a
mempty

txTimeEx2 :: ShelleyTx MaryEra
txTimeEx2 :: ShelleyTx MaryEra
txTimeEx2 =
  forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
    TxBody MaryEra
txbodyTimeEx2
    forall a. Monoid a => a
mempty
      { addrWits :: Set (WitVKey 'Witness)
addrWits =
          forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody MaryEra
txbodyTimeEx2) [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.alicePay]
      }
    forall a. StrictMaybe a
SNothing

expectedUTxOTimeEx2 :: UTxO MaryEra
expectedUTxOTimeEx2 :: UTxO MaryEra
expectedUTxOTimeEx2 =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [
        ( HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodyTimeEx2) Integer
0
        , forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr (forall t s. Inject t s => t -> s
Val.inject Coin
aliceCoinsTimeEx2)
        )
      , (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodyTimeEx2) Integer
1, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr MaryValue
bobTokensTimeEx2)
      , (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
1, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr (forall t s. Inject t s => t -> s
Val.inject Coin
bobInitCoin))
      ]

--------------------------------------------------------------
-- Introduce a new Token Bundle, Tokens only Alice can mint
--
-- Variables ending with SingExN (for a numeral N)
-- refer to this example.
--------------------------------------------------------------

alicePolicy :: Timelock MaryEra
alicePolicy :: Timelock MaryEra
alicePolicy = forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). VKey kd -> KeyHash kd
hashKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (kd :: KeyRole). KeyPair kd -> VKey kd
vKey forall a b. (a -> b) -> a -> b
$ KeyPair 'Payment
Cast.alicePay

alicePolicyId :: PolicyID
alicePolicyId :: PolicyID
alicePolicyId = ScriptHash -> PolicyID
PolicyID forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @MaryEra Timelock MaryEra
alicePolicy

tokenSingWitEx1 :: AssetName
tokenSingWitEx1 :: AssetName
tokenSingWitEx1 = ShortByteString -> AssetName
AssetName ShortByteString
"tokenSingWitEx1"

-----------------------
-- Mint Alice Tokens --
-----------------------

mintSingWitEx1 :: MultiAsset
mintSingWitEx1 :: MultiAsset
mintSingWitEx1 =
  Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
    forall k a. k -> a -> Map k a
Map.singleton PolicyID
alicePolicyId (forall k a. k -> a -> Map k a
Map.singleton AssetName
tokenSingWitEx1 Integer
17)

bobCoinsSingWitEx1 :: Coin
bobCoinsSingWitEx1 :: Coin
bobCoinsSingWitEx1 = Coin
bobInitCoin forall t. Val t => t -> t -> t
<-> Coin
feeEx

tokensSingWitEx1 :: MaryValue
tokensSingWitEx1 :: MaryValue
tokensSingWitEx1 = Coin -> MultiAsset -> MaryValue
MaryValue forall a. Monoid a => a
mempty MultiAsset
mintSingWitEx1 forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
Val.inject Coin
bobCoinsSingWitEx1

-- Bob pays the fees, but only alice can witness the minting
txbodySingWitEx1 :: TxBody MaryEra
txbodySingWitEx1 :: TxBody MaryEra
txbodySingWitEx1 =
  [TxIn]
-> [ShelleyTxOut MaryEra]
-> ValidityInterval
-> MultiAsset
-> TxBody MaryEra
makeMaryTxBody
    [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
1]
    [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr MaryValue
tokensSingWitEx1]
    ValidityInterval
unboundedInterval
    MultiAsset
mintSingWitEx1

txSingWitEx1Valid :: ShelleyTx MaryEra
txSingWitEx1Valid :: ShelleyTx MaryEra
txSingWitEx1Valid =
  forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody MaryEra
txbodySingWitEx1
    forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall era. EraTxWits era => TxWits era
mkBasicTxWits forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey 'Witness)
atw forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ScriptHash (Timelock MaryEra)
stw)
  where
    atw :: Set (WitVKey 'Witness)
atw = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody MaryEra
txbodySingWitEx1) [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.bobPay, forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.alicePay]
    stw :: Map ScriptHash (Timelock MaryEra)
stw = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PolicyID -> ScriptHash
policyID PolicyID
alicePolicyId, Timelock MaryEra
alicePolicy)]

expectedUTxOSingWitEx1 :: UTxO MaryEra
expectedUTxOSingWitEx1 :: UTxO MaryEra
expectedUTxOSingWitEx1 =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodySingWitEx1) Integer
0, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr MaryValue
tokensSingWitEx1)
      , (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
0, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr (forall t s. Inject t s => t -> s
Val.inject Coin
aliceInitCoin))
      ]

txSingWitEx1Invalid :: ShelleyTx MaryEra
txSingWitEx1Invalid :: ShelleyTx MaryEra
txSingWitEx1Invalid =
  forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody MaryEra
txbodySingWitEx1
    forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall era. EraTxWits era => TxWits era
mkBasicTxWits forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey 'Witness)
atw forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ScriptHash (Timelock MaryEra)
stw)
  where
    atw :: Set (WitVKey 'Witness)
atw = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody MaryEra
txbodySingWitEx1) [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.bobPay]
    stw :: Map ScriptHash (Timelock MaryEra)
stw = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PolicyID -> ScriptHash
policyID PolicyID
alicePolicyId, Timelock MaryEra
alicePolicy)]

------------------------
-- Mint Negative Values
--
-- Variables ending with NegExN (for a numeral N)
-- refer to this example. We assume that the simple
-- tokens in the SimpleEx1 example have been minted
-- and we use expectedUTxOSimpleEx1 as our starting
-- state.
------------------------

-- Mint negative valued tokens
mintNegEx1 :: MultiAsset
mintNegEx1 :: MultiAsset
mintNegEx1 =
  Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
    forall k a. k -> a -> Map k a
Map.singleton PolicyID
purplePolicyId (forall k a. k -> a -> Map k a
Map.singleton AssetName
plum (-Integer
8))

aliceTokensNegEx1 :: MaryValue
aliceTokensNegEx1 :: MaryValue
aliceTokensNegEx1 =
  Coin -> MultiAsset -> MaryValue
MaryValue (Coin
aliceCoinsSimpleEx2 forall t. Val t => t -> t -> t
<-> Coin
feeEx) forall a b. (a -> b) -> a -> b
$
    Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
      forall k a. k -> a -> Map k a
Map.singleton PolicyID
purplePolicyId (forall k a. k -> a -> Map k a
Map.singleton AssetName
amethyst Integer
2)

txbodyNegEx1 :: TxBody MaryEra
txbodyNegEx1 :: TxBody MaryEra
txbodyNegEx1 =
  [TxIn]
-> [ShelleyTxOut MaryEra]
-> ValidityInterval
-> MultiAsset
-> TxBody MaryEra
makeMaryTxBody
    [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodySimpleEx2) Integer
0]
    [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr MaryValue
aliceTokensNegEx1]
    ValidityInterval
unboundedInterval
    MultiAsset
mintNegEx1

txNegEx1 :: ShelleyTx MaryEra
txNegEx1 :: ShelleyTx MaryEra
txNegEx1 =
  forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody MaryEra
txbodyNegEx1
    forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall era. EraTxWits era => TxWits era
mkBasicTxWits forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey 'Witness)
atw forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ScriptHash (Timelock MaryEra)
stw)
  where
    atw :: Set (WitVKey 'Witness)
atw = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody MaryEra
txbodyNegEx1) [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.alicePay]
    stw :: Map ScriptHash (Timelock MaryEra)
stw = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PolicyID -> ScriptHash
policyID PolicyID
purplePolicyId, Timelock MaryEra
purplePolicy)]

initialUTxONegEx1 :: UTxO MaryEra
initialUTxONegEx1 :: UTxO MaryEra
initialUTxONegEx1 = UTxO MaryEra
expectedUTxOSimpleEx2

expectedUTxONegEx1 :: UTxO MaryEra
expectedUTxONegEx1 :: UTxO MaryEra
expectedUTxONegEx1 =
  forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodyNegEx1) Integer
0, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr MaryValue
aliceTokensNegEx1)
      , (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
1, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr (forall t s. Inject t s => t -> s
Val.inject Coin
bobInitCoin))
      , (HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodySimpleEx2) Integer
1, forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.bobAddr MaryValue
bobTokensSimpleEx2)
      ]

--
-- Now attempt to produce negative outputs
--

mintNegEx2 :: MultiAsset
mintNegEx2 :: MultiAsset
mintNegEx2 =
  Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
    forall k a. k -> a -> Map k a
Map.singleton PolicyID
purplePolicyId (forall k a. k -> a -> Map k a
Map.singleton AssetName
plum (-Integer
9))

aliceTokensNegEx2 :: MaryValue
aliceTokensNegEx2 :: MaryValue
aliceTokensNegEx2 =
  Coin -> MultiAsset -> MaryValue
MaryValue (Coin
aliceCoinsSimpleEx2 forall t. Val t => t -> t -> t
<-> Coin
feeEx) forall a b. (a -> b) -> a -> b
$
    Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
      forall k a. k -> a -> Map k a
Map.singleton PolicyID
purplePolicyId (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AssetName
plum, -Integer
1), (AssetName
amethyst, Integer
2)])

-- Mint negative valued tokens
txbodyNegEx2 :: TxBody MaryEra
txbodyNegEx2 :: TxBody MaryEra
txbodyNegEx2 =
  [TxIn]
-> [ShelleyTxOut MaryEra]
-> ValidityInterval
-> MultiAsset
-> TxBody MaryEra
makeMaryTxBody
    [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial (forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody TxBody MaryEra
txbodySimpleEx2) Integer
0]
    [forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr MaryValue
aliceTokensNegEx2]
    ValidityInterval
unboundedInterval
    MultiAsset
mintNegEx2

testNegEx2 :: Assertion
testNegEx2 :: Assertion
testNegEx2 = do
  Either ErrorCall Bool
r <- forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. a -> IO a
evaluate forall a b. (a -> b) -> a -> b
$ TxBody MaryEra
txbodyNegEx2 forall a. Eq a => a -> a -> Bool
== TxBody MaryEra
txbodyNegEx2)
  case Either ErrorCall Bool
r of
    Left (ErrorCall String
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Right Bool
_ -> forall a. HasCallStack => String -> IO a
assertFailure String
"constructed negative ShelleyTxOut Value"

--
-- Create a Value that is too big
--

minUtxoBigEx :: Coin
minUtxoBigEx :: Coin
minUtxoBigEx = Integer -> Coin
Coin Integer
50000

smallValue :: MultiAsset
smallValue :: MultiAsset
smallValue =
  Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
    forall k a. k -> a -> Map k a
Map.singleton PolicyID
purplePolicyId (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AssetName
plum, Integer
13), (AssetName
amethyst, Integer
2)])

smallOut :: ShelleyTxOut MaryEra
smallOut :: ShelleyTxOut MaryEra
smallOut =
  forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr forall a b. (a -> b) -> a -> b
$
    Coin -> MultiAsset -> MaryValue
MaryValue forall a. Monoid a => a
mempty MultiAsset
smallValue
      forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
Val.inject (Coin
aliceInitCoin forall t. Val t => t -> t -> t
<-> (Coin
feeEx forall t. Val t => t -> t -> t
<+> Coin
minUtxoBigEx))

numAssets :: Int
numAssets :: Int
numAssets = Int
1000

bigValue :: MultiAsset
bigValue :: MultiAsset
bigValue =
  Map PolicyID (Map AssetName Integer) -> MultiAsset
MultiAsset forall a b. (a -> b) -> a -> b
$
    forall k a. k -> a -> Map k a
Map.singleton
      PolicyID
purplePolicyId
      (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Int
x -> (ShortByteString -> AssetName
AssetName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Int
x, Integer
1)) [Int
1 .. Int
numAssets])

bigOut :: ShelleyTxOut MaryEra
bigOut :: ShelleyTxOut MaryEra
bigOut = forall era.
(HasCallStack, Era era, Val (Value era)) =>
Addr -> Value era -> ShelleyTxOut era
ShelleyTxOut Addr
Cast.aliceAddr forall a b. (a -> b) -> a -> b
$ Coin -> MultiAsset -> MaryValue
MaryValue forall a. Monoid a => a
mempty MultiAsset
bigValue forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
Val.inject Coin
minUtxoBigEx

txbodyWithBigValue :: TxBody MaryEra
txbodyWithBigValue :: TxBody MaryEra
txbodyWithBigValue =
  [TxIn]
-> [ShelleyTxOut MaryEra]
-> ValidityInterval
-> MultiAsset
-> TxBody MaryEra
makeMaryTxBody
    [HasCallStack => TxId -> Integer -> TxIn
mkTxInPartial TxId
bootstrapTxId Integer
0]
    [ShelleyTxOut MaryEra
smallOut, ShelleyTxOut MaryEra
bigOut]
    ValidityInterval
unboundedInterval
    (MultiAsset
bigValue forall a. Semigroup a => a -> a -> a
<> MultiAsset
smallValue)

txBigValue :: ShelleyTx MaryEra
txBigValue :: ShelleyTx MaryEra
txBigValue =
  forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody MaryEra
txbodyWithBigValue
    forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (forall era. EraTxWits era => TxWits era
mkBasicTxWits forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (WitVKey 'Witness)
atw forall a b. a -> (a -> b) -> b
& forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ScriptHash (Timelock MaryEra)
stw)
  where
    atw :: Set (WitVKey 'Witness)
atw = forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody MaryEra
txbodyWithBigValue) [forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyPair 'Payment
Cast.alicePay]
    stw :: Map ScriptHash (Timelock MaryEra)
stw = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PolicyID -> ScriptHash
policyID PolicyID
purplePolicyId, Timelock MaryEra
purplePolicy)]

--
-- Multi-Assets Test Group
--

multiAssetsExample :: TestTree
multiAssetsExample :: TestTree
multiAssetsExample =
  String -> [TestTree] -> TestTree
testGroup
    String
"multi-assets"
    [ String -> [TestTree] -> TestTree
testGroup
        String
"simple"
        [ String -> Assertion -> TestTree
testCase String
"minting" forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
              UTxO MaryEra
initUTxO
              ShelleyTx MaryEra
txSimpleEx1
              (SlotNo -> LedgerEnv MaryEra
ledgerEnv forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo Word64
0)
              (forall a b. b -> Either a b
Right UTxO MaryEra
expectedUTxOSimpleEx1)
        , String -> Assertion -> TestTree
testCase String
"transfer" forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
              UTxO MaryEra
expectedUTxOSimpleEx1
              ShelleyTx MaryEra
txSimpleEx2
              (SlotNo -> LedgerEnv MaryEra
ledgerEnv forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo Word64
1)
              (forall a b. b -> Either a b
Right UTxO MaryEra
expectedUTxOSimpleEx2)
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"bounded time interval"
        [ String -> Assertion -> TestTree
testCase String
"minting, valid" forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
              UTxO MaryEra
initUTxO
              ShelleyTx MaryEra
txTimeEx1Valid
              (SlotNo -> LedgerEnv MaryEra
ledgerEnv SlotNo
startInterval)
              (forall a b. b -> Either a b
Right UTxO MaryEra
expectedUTxOTimeEx1)
        , String -> Assertion -> TestTree
testCase String
"minting, invalid LHS too small" forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
              UTxO MaryEra
initUTxO
              ShelleyTx MaryEra
txTimeEx1InvalidLHSfixed
              (SlotNo -> LedgerEnv MaryEra
ledgerEnv SlotNo
startInterval)
              (PolicyID
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
policyFailure PolicyID
boundedTimePolicyId)
        , String -> Assertion -> TestTree
testCase String
"minting, invalid LHS unspecified" forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
              UTxO MaryEra
initUTxO
              ShelleyTx MaryEra
txTimeEx1InvalidLHSopen
              (SlotNo -> LedgerEnv MaryEra
ledgerEnv SlotNo
startInterval)
              (PolicyID
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
policyFailure PolicyID
boundedTimePolicyId)
        , String -> Assertion -> TestTree
testCase String
"minting, invalid RHS too big" forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
              UTxO MaryEra
initUTxO
              ShelleyTx MaryEra
txTimeEx1InvalidRHSfixed
              (SlotNo -> LedgerEnv MaryEra
ledgerEnv SlotNo
startInterval)
              (PolicyID
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
policyFailure PolicyID
boundedTimePolicyId)
        , String -> Assertion -> TestTree
testCase String
"minting, invalid RHS unspecified" forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
              UTxO MaryEra
initUTxO
              ShelleyTx MaryEra
txTimeEx1InvalidRHSopen
              (SlotNo -> LedgerEnv MaryEra
ledgerEnv SlotNo
startInterval)
              (PolicyID
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
policyFailure PolicyID
boundedTimePolicyId)
        , String -> Assertion -> TestTree
testCase String
"transfer, after minting period" forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
              UTxO MaryEra
expectedUTxOTimeEx1
              ShelleyTx MaryEra
txTimeEx2
              (SlotNo -> LedgerEnv MaryEra
ledgerEnv SlotNo
afterStop)
              (forall a b. b -> Either a b
Right UTxO MaryEra
expectedUTxOTimeEx2)
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"single key"
        [ String -> Assertion -> TestTree
testCase String
"minting, valid" forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
              UTxO MaryEra
initUTxO
              ShelleyTx MaryEra
txSingWitEx1Valid
              (SlotNo -> LedgerEnv MaryEra
ledgerEnv forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo Word64
0)
              (forall a b. b -> Either a b
Right UTxO MaryEra
expectedUTxOSingWitEx1)
        , String -> Assertion -> TestTree
testCase String
"minting, invalid no mint signature" forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
              UTxO MaryEra
initUTxO
              ShelleyTx MaryEra
txSingWitEx1Invalid
              (SlotNo -> LedgerEnv MaryEra
ledgerEnv forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo Word64
0)
              (PolicyID
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
policyFailure PolicyID
alicePolicyId)
        ]
    , String -> [TestTree] -> TestTree
testGroup
        String
"negative minting"
        [ String -> Assertion -> TestTree
testCase String
"remove assets" forall a b. (a -> b) -> a -> b
$
            HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
              UTxO MaryEra
initialUTxONegEx1
              ShelleyTx MaryEra
txNegEx1
              (SlotNo -> LedgerEnv MaryEra
ledgerEnv forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo Word64
3)
              (forall a b. b -> Either a b
Right UTxO MaryEra
expectedUTxONegEx1)
        , String -> Assertion -> TestTree
testCase String
"no negative outputs" Assertion
testNegEx2
        ]
    , String -> Assertion -> TestTree
testCase String
"value too big" forall a b. (a -> b) -> a -> b
$
        HasCallStack =>
UTxO MaryEra
-> ShelleyTx MaryEra
-> LedgerEnv MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
-> Assertion
testMaryNoDelegLEDGER
          UTxO MaryEra
initUTxO
          ShelleyTx MaryEra
txBigValue
          (SlotNo -> LedgerEnv MaryEra
ledgerEnv forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo Word64
0)
          (ShelleyTxOut MaryEra
-> Either
     (NonEmpty (PredicateFailure (ShelleyLEDGER MaryEra)))
     (UTxO MaryEra)
outTooBigFailure ShelleyTxOut MaryEra
bigOut)
    ]