{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Cardano.Ledger.Shelley.MultiSigExamples (
  applyTxWithScript,
  aliceOnly,
  bobOnly,
  aliceAndBob,
  aliceOrBob,
  aliceAndBobOrCarl,
  aliceAndBobOrCarlAndDaria,
  aliceAndBobOrCarlOrDaria,
) where

import qualified Cardano.Crypto.Hash as Hash
import Cardano.Ledger.Address (Addr (Addr))
import Cardano.Ledger.BaseTypes (
  Network (..),
  StrictMaybe (..),
  maybeToStrictMaybe,
  mkTxIxPartial,
 )
import Cardano.Ledger.Coin
import Cardano.Ledger.Credential (
  pattern KeyHashObj,
  pattern ScriptHashObj,
  pattern StakeRefBase,
 )
import Cardano.Ledger.Keys (asWitness)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  LedgerState (..),
  UTxOState,
  genesisState,
 )
import Cardano.Ledger.Shelley.Rules (ShelleyUTXOW, UtxoEnv (..))
import Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.Tx (ShelleyTx (..))
import Cardano.Ledger.Shelley.TxAuxData (ShelleyTxAuxData)
import Cardano.Ledger.Shelley.TxBody (TxBody (ShelleyTxBody))
import Cardano.Ledger.Shelley.TxWits (ShelleyTxWits (..))
import Cardano.Ledger.Slot (SlotNo (..))
import Cardano.Ledger.TxIn (TxId, TxIn (..))
import qualified Cardano.Ledger.Val as Val
import Control.State.Transition
import Data.Default (Default (def))
import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map (empty, fromList)
import Data.Sequence.Strict (StrictSeq (..))
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set (fromList)
import Lens.Micro
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkWitnessesVKey)
import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast
import Test.Cardano.Ledger.Shelley.Generator.Core (genesisCoins)
import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId)
import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen ()
import Test.Cardano.Ledger.Shelley.Utils

-- Multi-Signature tests

-- This compile-time test asserts that the script hash and key hash use the
-- same hash size and indeed hash function. We do this by checking we can
-- type-check the following code that converts between them by using the hash
-- casting function which changes what the hash is of, without changing the
-- hashing algorithm.
--
_assertScriptHashSizeMatchesAddrHashSize :: ScriptHash -> KeyHash r
_assertScriptHashSizeMatchesAddrHashSize :: forall (r :: KeyRole). ScriptHash -> KeyHash r
_assertScriptHashSizeMatchesAddrHashSize (ScriptHash Hash ADDRHASH EraIndependentScript
h) = Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
forall (r :: KeyRole).
Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
KeyHash (Hash ADDRHASH EraIndependentScript
-> Hash ADDRHASH (VerKeyDSIGN DSIGN)
forall h a b. Hash h a -> Hash h b
Hash.castHash Hash ADDRHASH EraIndependentScript
h)

-- Multi-signature scripts
singleKeyOnly :: ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly :: forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly (Addr Network
_ (KeyHashObj KeyHash 'Payment
pk) StakeReference
_) = KeyHash 'Witness -> NativeScript era
forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature (KeyHash 'Witness -> NativeScript era)
-> KeyHash 'Witness -> NativeScript era
forall a b. (a -> b) -> a -> b
$ KeyHash 'Payment -> KeyHash 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness KeyHash 'Payment
pk
singleKeyOnly Addr
_ = [Char] -> NativeScript era
forall a. HasCallStack => [Char] -> a
error [Char]
"use VKey address"

aliceOnly :: ShelleyEraScript era => NativeScript era
aliceOnly :: forall era. ShelleyEraScript era => NativeScript era
aliceOnly = Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.aliceAddr

bobOnly :: ShelleyEraScript era => NativeScript era
bobOnly :: forall era. ShelleyEraScript era => NativeScript era
bobOnly = Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.bobAddr

aliceOrBob :: ShelleyEraScript era => NativeScript era
aliceOrBob :: forall era. ShelleyEraScript era => NativeScript era
aliceOrBob = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [NativeScript era
forall era. ShelleyEraScript era => NativeScript era
aliceOnly, Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.bobAddr])

aliceAndBob :: ShelleyEraScript era => NativeScript era
aliceAndBob :: forall era. ShelleyEraScript era => NativeScript era
aliceAndBob = StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [NativeScript era
forall era. ShelleyEraScript era => NativeScript era
aliceOnly, Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.bobAddr])

aliceAndBobOrCarl :: ShelleyEraScript era => NativeScript era
aliceAndBobOrCarl :: forall era. ShelleyEraScript era => NativeScript era
aliceAndBobOrCarl = Int -> StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
1 ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [NativeScript era
forall era. ShelleyEraScript era => NativeScript era
aliceAndBob, Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.carlAddr])

aliceAndBobOrCarlAndDaria :: ShelleyEraScript era => NativeScript era
aliceAndBobOrCarlAndDaria :: forall era. ShelleyEraScript era => NativeScript era
aliceAndBobOrCarlAndDaria =
  StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf (StrictSeq (NativeScript era) -> NativeScript era)
-> StrictSeq (NativeScript era) -> NativeScript era
forall a b. (a -> b) -> a -> b
$
    [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
      [ NativeScript era
forall era. ShelleyEraScript era => NativeScript era
aliceAndBob
      , StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.carlAddr, Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.dariaAddr])
      ]

aliceAndBobOrCarlOrDaria ::
  ShelleyEraScript era =>
  NativeScript era
aliceAndBobOrCarlOrDaria :: forall era. ShelleyEraScript era => NativeScript era
aliceAndBobOrCarlOrDaria =
  Int -> StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf
    Int
1
    (StrictSeq (NativeScript era) -> NativeScript era)
-> StrictSeq (NativeScript era) -> NativeScript era
forall a b. (a -> b) -> a -> b
$ [NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList
      [ NativeScript era
forall era. ShelleyEraScript era => NativeScript era
aliceAndBob
      , StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf ([NativeScript era] -> StrictSeq (NativeScript era)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.carlAddr, Addr -> NativeScript era
forall era. ShelleyEraScript era => Addr -> NativeScript era
singleKeyOnly Addr
Cast.dariaAddr])
      ]

initTxBody ::
  [(Addr, Value ShelleyEra)] ->
  TxBody ShelleyEra
initTxBody :: [(Addr, Value ShelleyEra)] -> TxBody ShelleyEra
initTxBody [(Addr, Value ShelleyEra)]
addrs =
  Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> TxBody ShelleyEra
ShelleyTxBody
    ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [TxId -> TxIx -> TxIn
TxIn TxId
genesisId TxIx
forall a. Bounded a => a
minBound, TxId -> TxIx -> TxIn
TxIn TxId
genesisId (HasCallStack => Integer -> TxIx
Integer -> TxIx
mkTxIxPartial Integer
1)])
    ([TxOut ShelleyEra] -> StrictSeq (TxOut ShelleyEra)
forall a. [a] -> StrictSeq a
StrictSeq.fromList ([TxOut ShelleyEra] -> StrictSeq (TxOut ShelleyEra))
-> [TxOut ShelleyEra] -> StrictSeq (TxOut ShelleyEra)
forall a b. (a -> b) -> a -> b
$ ((Addr, Value ShelleyEra) -> ShelleyTxOut ShelleyEra)
-> [(Addr, Value ShelleyEra)] -> [ShelleyTxOut ShelleyEra]
forall a b. (a -> b) -> [a] -> [b]
map ((Addr -> Value ShelleyEra -> ShelleyTxOut ShelleyEra)
-> (Addr, Value ShelleyEra) -> ShelleyTxOut ShelleyEra
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Addr -> Value ShelleyEra -> TxOut ShelleyEra
Addr -> Value ShelleyEra -> ShelleyTxOut ShelleyEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut) [(Addr, Value ShelleyEra)]
addrs)
    StrictSeq (TxCert ShelleyEra)
StrictSeq (ShelleyTxCert ShelleyEra)
forall a. StrictSeq a
Empty
    (Map RewardAccount Coin -> Withdrawals
Withdrawals Map RewardAccount Coin
forall k a. Map k a
Map.empty)
    (Integer -> Coin
Coin Integer
0)
    (Word64 -> SlotNo
SlotNo Word64
0)
    StrictMaybe (Update ShelleyEra)
forall a. StrictMaybe a
SNothing
    StrictMaybe TxAuxDataHash
forall a. StrictMaybe a
SNothing

makeTxBody ::
  [TxIn] ->
  [(Addr, Value ShelleyEra)] ->
  Withdrawals ->
  TxBody ShelleyEra
makeTxBody :: [TxIn]
-> [(Addr, Value ShelleyEra)] -> Withdrawals -> TxBody ShelleyEra
makeTxBody [TxIn]
inp [(Addr, Value ShelleyEra)]
addrCs Withdrawals
wdrl =
  Set TxIn
-> StrictSeq (TxOut ShelleyEra)
-> StrictSeq (TxCert ShelleyEra)
-> Withdrawals
-> Coin
-> SlotNo
-> StrictMaybe (Update ShelleyEra)
-> StrictMaybe TxAuxDataHash
-> TxBody ShelleyEra
ShelleyTxBody
    ([TxIn] -> Set TxIn
forall a. Ord a => [a] -> Set a
Set.fromList [TxIn]
inp)
    ([ShelleyTxOut ShelleyEra] -> StrictSeq (ShelleyTxOut ShelleyEra)
forall a. [a] -> StrictSeq a
StrictSeq.fromList [(Addr -> Coin -> ShelleyTxOut ShelleyEra)
-> (Addr, Coin) -> ShelleyTxOut ShelleyEra
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Addr -> Value ShelleyEra -> TxOut ShelleyEra
Addr -> Coin -> ShelleyTxOut ShelleyEra
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut (Addr, Coin)
addrC | (Addr, Coin)
addrC <- [(Addr, Value ShelleyEra)]
[(Addr, Coin)]
addrCs])
    StrictSeq (TxCert ShelleyEra)
StrictSeq (ShelleyTxCert ShelleyEra)
forall a. StrictSeq a
Empty
    Withdrawals
wdrl
    (Integer -> Coin
Coin Integer
0)
    (Word64 -> SlotNo
SlotNo Word64
10)
    StrictMaybe (Update ShelleyEra)
forall a. StrictMaybe a
SNothing
    StrictMaybe TxAuxDataHash
forall a. StrictMaybe a
SNothing

makeTx ::
  TxBody ShelleyEra ->
  [KeyPair 'Witness] ->
  Map ScriptHash (MultiSig ShelleyEra) ->
  Maybe (ShelleyTxAuxData ShelleyEra) ->
  ShelleyTx ShelleyEra
makeTx :: TxBody ShelleyEra
-> [KeyPair 'Witness]
-> Map ScriptHash (MultiSig ShelleyEra)
-> Maybe (ShelleyTxAuxData ShelleyEra)
-> ShelleyTx ShelleyEra
makeTx TxBody ShelleyEra
txBody [KeyPair 'Witness]
keyPairs Map ScriptHash (MultiSig ShelleyEra)
msigs = TxBody ShelleyEra
-> TxWits ShelleyEra
-> StrictMaybe (TxAuxData ShelleyEra)
-> ShelleyTx ShelleyEra
forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx TxBody ShelleyEra
txBody TxWits ShelleyEra
ShelleyTxWits ShelleyEra
txWits (StrictMaybe (ShelleyTxAuxData ShelleyEra) -> ShelleyTx ShelleyEra)
-> (Maybe (ShelleyTxAuxData ShelleyEra)
    -> StrictMaybe (ShelleyTxAuxData ShelleyEra))
-> Maybe (ShelleyTxAuxData ShelleyEra)
-> ShelleyTx ShelleyEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (ShelleyTxAuxData ShelleyEra)
-> StrictMaybe (ShelleyTxAuxData ShelleyEra)
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe
  where
    txWits :: ShelleyTxWits ShelleyEra
    txWits :: ShelleyTxWits ShelleyEra
txWits =
      TxWits ShelleyEra
forall era. EraTxWits era => TxWits era
mkBasicTxWits
        TxWits ShelleyEra
-> (TxWits ShelleyEra -> TxWits ShelleyEra) -> TxWits ShelleyEra
forall a b. a -> (a -> b) -> b
& (Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
-> TxWits ShelleyEra -> Identity (TxWits ShelleyEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits ShelleyEra) (Set (WitVKey 'Witness))
addrTxWitsL ((Set (WitVKey 'Witness) -> Identity (Set (WitVKey 'Witness)))
 -> TxWits ShelleyEra -> Identity (TxWits ShelleyEra))
-> Set (WitVKey 'Witness) -> TxWits ShelleyEra -> TxWits ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SafeHash EraIndependentTxBody
-> [KeyPair 'Witness] -> Set (WitVKey 'Witness)
forall (kr :: KeyRole).
SafeHash EraIndependentTxBody
-> [KeyPair kr] -> Set (WitVKey 'Witness)
mkWitnessesVKey (TxBody ShelleyEra -> SafeHash EraIndependentTxBody
forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody ShelleyEra
txBody) [KeyPair 'Witness]
keyPairs
        TxWits ShelleyEra
-> (TxWits ShelleyEra -> ShelleyTxWits ShelleyEra)
-> ShelleyTxWits ShelleyEra
forall a b. a -> (a -> b) -> b
& (Map ScriptHash (Script ShelleyEra)
 -> Identity (Map ScriptHash (Script ShelleyEra)))
-> TxWits ShelleyEra -> Identity (TxWits ShelleyEra)
(Map ScriptHash (Script ShelleyEra)
 -> Identity (Map ScriptHash (MultiSig ShelleyEra)))
-> TxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits ShelleyEra) (Map ScriptHash (Script ShelleyEra))
scriptTxWitsL ((Map ScriptHash (Script ShelleyEra)
  -> Identity (Map ScriptHash (MultiSig ShelleyEra)))
 -> TxWits ShelleyEra -> Identity (ShelleyTxWits ShelleyEra))
-> Map ScriptHash (MultiSig ShelleyEra)
-> TxWits ShelleyEra
-> ShelleyTxWits ShelleyEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map ScriptHash (MultiSig ShelleyEra)
msigs

aliceInitCoin :: Coin
aliceInitCoin :: Coin
aliceInitCoin = Integer -> Coin
Coin Integer
10000

bobInitCoin :: Coin
bobInitCoin :: Coin
bobInitCoin = Integer -> Coin
Coin Integer
1000

genesis ::
  forall era.
  ( EraTxOut era
  , EraGov era
  , EraStake era
  , EraCertState era
  ) =>
  LedgerState era
genesis :: forall era.
(EraTxOut era, EraGov era, EraStake era, EraCertState era) =>
LedgerState era
genesis = Map (KeyHash 'Genesis) GenDelegPair -> UTxO era -> LedgerState era
forall era.
(EraGov era, EraCertState era, EraStake era) =>
Map (KeyHash 'Genesis) GenDelegPair -> UTxO era -> LedgerState era
genesisState Map (KeyHash 'Genesis) GenDelegPair
forall k a. Map k a
genDelegs0 UTxO era
utxo0
  where
    genDelegs0 :: Map k a
genDelegs0 = Map k a
forall k a. Map k a
Map.empty
    utxo0 :: UTxO era
utxo0 =
      forall era. TxId -> [TxOut era] -> UTxO era
genesisCoins @era
        TxId
genesisId
        [ Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
Cast.aliceAddr (Coin -> Value era
forall t s. Inject t s => t -> s
Val.inject Coin
aliceInitCoin)
        , Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
Cast.bobAddr (Coin -> Value era
forall t s. Inject t s => t -> s
Val.inject Coin
bobInitCoin)
        ]

initPParams :: EraPParams era => PParams era
initPParams :: forall era. EraPParams era => PParams era
initPParams =
  PParams era
forall era. EraPParams era => PParams era
emptyPParams
    PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Word32 -> Identity Word32)
-> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
ppMaxTxSizeL ((Word32 -> Identity Word32)
 -> PParams era -> Identity (PParams era))
-> Word32 -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
1000

-- | Create an initial UTxO state where Alice has 'aliceInitCoin' and Bob
-- 'bobInitCoin' to spend. Then create and apply a transaction which, if
-- 'aliceKeep' is greater than 0, gives that amount to Alice and creates outputs
-- locked by a script for each pair of script, coin value in 'msigs'.
initialUTxOState ::
  Coin ->
  [(MultiSig ShelleyEra, Coin)] ->
  ( TxId
  , Either
      (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
      (UTxOState ShelleyEra)
  )
initialUTxOState :: Coin
-> [(MultiSig ShelleyEra, Coin)]
-> (TxId,
    Either
      (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
      (UTxOState ShelleyEra))
initialUTxOState Coin
aliceKeep [(MultiSig ShelleyEra, Coin)]
msigs =
  let addresses :: [(Addr, Coin)]
addresses =
        [(Addr
Cast.aliceAddr, Coin
aliceKeep) | (Integer -> Integer -> Bool) -> Coin -> Coin -> Bool
forall t. Val t => (Integer -> Integer -> Bool) -> t -> t -> Bool
Val.pointwise Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>) Coin
aliceKeep Coin
forall a. Monoid a => a
mempty]
          [(Addr, Coin)] -> [(Addr, Coin)] -> [(Addr, Coin)]
forall a. [a] -> [a] -> [a]
++ ((MultiSig ShelleyEra, Coin) -> (Addr, Coin))
-> [(MultiSig ShelleyEra, Coin)] -> [(Addr, Coin)]
forall a b. (a -> b) -> [a] -> [b]
map
            ( \(MultiSig ShelleyEra
msig, Coin
era) ->
                ( Network -> Credential 'Payment -> StakeReference -> Addr
Addr
                    Network
Testnet
                    (ScriptHash -> Credential 'Payment
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> Credential 'Payment)
-> ScriptHash -> Credential 'Payment
forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @ShelleyEra Script ShelleyEra
MultiSig ShelleyEra
msig)
                    (StakeCredential -> StakeReference
StakeRefBase (StakeCredential -> StakeReference)
-> StakeCredential -> StakeReference
forall a b. (a -> b) -> a -> b
$ ScriptHash -> StakeCredential
forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj (ScriptHash -> StakeCredential) -> ScriptHash -> StakeCredential
forall a b. (a -> b) -> a -> b
$ forall era. EraScript era => Script era -> ScriptHash
hashScript @ShelleyEra Script ShelleyEra
MultiSig ShelleyEra
msig)
                , Coin
era
                )
            )
            [(MultiSig ShelleyEra, Coin)]
msigs
   in let tx :: ShelleyTx ShelleyEra
tx =
            TxBody ShelleyEra
-> [KeyPair 'Witness]
-> Map ScriptHash (MultiSig ShelleyEra)
-> Maybe (ShelleyTxAuxData ShelleyEra)
-> ShelleyTx ShelleyEra
makeTx
              ([(Addr, Value ShelleyEra)] -> TxBody ShelleyEra
initTxBody [(Addr, Value ShelleyEra)]
[(Addr, Coin)]
addresses)
              (KeyPair 'Payment -> KeyPair 'Witness
forall (a :: KeyRole -> *) (r :: KeyRole).
HasKeyRole a =>
a r -> a 'Witness
asWitness (KeyPair 'Payment -> KeyPair 'Witness)
-> [KeyPair 'Payment] -> [KeyPair 'Witness]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyPair 'Payment
Cast.alicePay, KeyPair 'Payment
Cast.bobPay])
              Map ScriptHash (MultiSig ShelleyEra)
forall k a. Map k a
Map.empty
              Maybe (ShelleyTxAuxData ShelleyEra)
forall a. Maybe a
Nothing
       in ( Tx ShelleyEra -> TxId
forall era. EraTx era => Tx era -> TxId
txIdTx Tx ShelleyEra
ShelleyTx ShelleyEra
tx
          , ShelleyBase
  (Either
     (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
     (UTxOState ShelleyEra))
-> Either
     (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
     (UTxOState ShelleyEra)
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either
      (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
      (UTxOState ShelleyEra))
 -> Either
      (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
      (UTxOState ShelleyEra))
-> ShelleyBase
     (Either
        (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
        (UTxOState ShelleyEra))
-> Either
     (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
     (UTxOState ShelleyEra)
forall a b. (a -> b) -> a -> b
$
              forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTSTest @(ShelleyUTXOW ShelleyEra)
                ( (Environment (ShelleyUTXOW ShelleyEra),
 State (ShelleyUTXOW ShelleyEra), Signal (ShelleyUTXOW ShelleyEra))
-> TRC (ShelleyUTXOW ShelleyEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
                    ( SlotNo
-> PParams ShelleyEra -> CertState ShelleyEra -> UtxoEnv ShelleyEra
forall era. SlotNo -> PParams era -> CertState era -> UtxoEnv era
UtxoEnv
                        (Word64 -> SlotNo
SlotNo Word64
0)
                        PParams ShelleyEra
forall era. EraPParams era => PParams era
initPParams
                        CertState ShelleyEra
ShelleyCertState ShelleyEra
forall a. Default a => a
def
                    , LedgerState ShelleyEra -> UTxOState ShelleyEra
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState ShelleyEra
forall era.
(EraTxOut era, EraGov era, EraStake era, EraCertState era) =>
LedgerState era
genesis
                    , ShelleyTx ShelleyEra
Signal (ShelleyUTXOW ShelleyEra)
tx
                    )
                )
          )

-- | Start from genesis, consume Alice's and Bob's coins, create an output
-- spendable by Alice if 'aliceKeep' is greater than 0. For each pair of script
-- and coin value in 'lockScripts' create an output of that value locked by the
-- script. Sign the transaction with keys in 'signers'. Then create an
-- transaction that uses the scripts in 'unlockScripts' (and the output for
-- 'aliceKeep' in the case of it being non-zero) to spend all funds back to
-- Alice. Return resulting UTxO state or collected errors
applyTxWithScript ::
  [(MultiSig ShelleyEra, Coin)] ->
  [MultiSig ShelleyEra] ->
  Withdrawals ->
  Coin ->
  [KeyPair 'Witness] ->
  Either (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra))) (UTxOState ShelleyEra)
applyTxWithScript :: [(MultiSig ShelleyEra, Coin)]
-> [MultiSig ShelleyEra]
-> Withdrawals
-> Coin
-> [KeyPair 'Witness]
-> Either
     (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
     (UTxOState ShelleyEra)
applyTxWithScript [(MultiSig ShelleyEra, Coin)]
lockScripts [MultiSig ShelleyEra]
unlockScripts Withdrawals
wdrl Coin
aliceKeep [KeyPair 'Witness]
signers = Either
  (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
  (UTxOState ShelleyEra)
Either
  (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
  (UTxOState ShelleyEra)
utxoSt'
  where
    (TxId
txId, Either
  (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
  (UTxOState ShelleyEra)
initUtxo) = Coin
-> [(MultiSig ShelleyEra, Coin)]
-> (TxId,
    Either
      (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
      (UTxOState ShelleyEra))
initialUTxOState Coin
aliceKeep [(MultiSig ShelleyEra, Coin)]
lockScripts
    utxoSt :: UTxOState ShelleyEra
utxoSt = case Either
  (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
  (UTxOState ShelleyEra)
initUtxo of
      Right UTxOState ShelleyEra
utxoSt'' -> UTxOState ShelleyEra
utxoSt''
      Either
  (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
  (UTxOState ShelleyEra)
_ -> [Char] -> UTxOState ShelleyEra
forall a. HasCallStack => [Char] -> a
error ([Char] -> UTxOState ShelleyEra) -> [Char] -> UTxOState ShelleyEra
forall a b. (a -> b) -> a -> b
$ [Char]
"must fail test before: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Either
  (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
  (UTxOState ShelleyEra)
-> [Char]
forall a. Show a => a -> [Char]
show Either
  (NonEmpty (PredicateFailure (ShelleyUTXOW ShelleyEra)))
  (UTxOState ShelleyEra)
Either
  (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
  (UTxOState ShelleyEra)
initUtxo
    txbody :: TxBody ShelleyEra
txbody =
      [TxIn]
-> [(Addr, Value ShelleyEra)] -> Withdrawals -> TxBody ShelleyEra
makeTxBody
        [TxIn]
inputs'
        [(Addr
Cast.aliceAddr, Coin -> Value ShelleyEra
forall t s. Inject t s => t -> s
Val.inject (Coin -> Value ShelleyEra) -> Coin -> Value ShelleyEra
forall a b. (a -> b) -> a -> b
$ Coin
aliceInitCoin Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
bobInitCoin Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Map RewardAccount Coin -> Coin
forall m. Monoid m => Map RewardAccount m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Withdrawals -> Map RewardAccount Coin
unWithdrawals Withdrawals
wdrl))]
        Withdrawals
wdrl
    inputs' :: [TxIn]
inputs' =
      [ TxId -> TxIx -> TxIn
TxIn TxId
txId (HasCallStack => Integer -> TxIx
Integer -> TxIx
mkTxIxPartial (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n))
      | Int
n <-
          [Int
0 .. [(MultiSig ShelleyEra, Coin)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(MultiSig ShelleyEra, Coin)]
lockScripts Int -> Int -> Int
forall a. Num a => a -> a -> a
- if (Integer -> Integer -> Bool) -> Coin -> Coin -> Bool
forall t. Val t => (Integer -> Integer -> Bool) -> t -> t -> Bool
Val.pointwise Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(>) Coin
aliceKeep Coin
forall a. Monoid a => a
mempty then Int
0 else Int
1]
      ]
    -- alice? + scripts
    tx :: ShelleyTx ShelleyEra
tx =
      TxBody ShelleyEra
-> [KeyPair 'Witness]
-> Map ScriptHash (MultiSig ShelleyEra)
-> Maybe (ShelleyTxAuxData ShelleyEra)
-> ShelleyTx ShelleyEra
makeTx
        TxBody ShelleyEra
txbody
        [KeyPair 'Witness]
signers
        ([(ScriptHash, MultiSig ShelleyEra)]
-> Map ScriptHash (MultiSig ShelleyEra)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ScriptHash, MultiSig ShelleyEra)]
 -> Map ScriptHash (MultiSig ShelleyEra))
-> [(ScriptHash, MultiSig ShelleyEra)]
-> Map ScriptHash (MultiSig ShelleyEra)
forall a b. (a -> b) -> a -> b
$ (MultiSig ShelleyEra -> (ScriptHash, MultiSig ShelleyEra))
-> [MultiSig ShelleyEra] -> [(ScriptHash, MultiSig ShelleyEra)]
forall a b. (a -> b) -> [a] -> [b]
map (\MultiSig ShelleyEra
scr -> (forall era. EraScript era => Script era -> ScriptHash
hashScript @ShelleyEra Script ShelleyEra
MultiSig ShelleyEra
scr, MultiSig ShelleyEra
scr)) [MultiSig ShelleyEra]
unlockScripts)
        Maybe (ShelleyTxAuxData ShelleyEra)
forall a. Maybe a
Nothing
    utxoSt' :: Either
  (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
  (UTxOState ShelleyEra)
utxoSt' =
      ShelleyBase
  (Either
     (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
     (UTxOState ShelleyEra))
-> Either
     (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
     (UTxOState ShelleyEra)
forall a. ShelleyBase a -> a
runShelleyBase (ShelleyBase
   (Either
      (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
      (UTxOState ShelleyEra))
 -> Either
      (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
      (UTxOState ShelleyEra))
-> ShelleyBase
     (Either
        (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
        (UTxOState ShelleyEra))
-> Either
     (NonEmpty (ShelleyUtxowPredFailure ShelleyEra))
     (UTxOState ShelleyEra)
forall a b. (a -> b) -> a -> b
$
        forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTSTest @(ShelleyUTXOW ShelleyEra)
          ( (Environment (ShelleyUTXOW ShelleyEra),
 State (ShelleyUTXOW ShelleyEra), Signal (ShelleyUTXOW ShelleyEra))
-> TRC (ShelleyUTXOW ShelleyEra)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
              ( SlotNo
-> PParams ShelleyEra -> CertState ShelleyEra -> UtxoEnv ShelleyEra
forall era. SlotNo -> PParams era -> CertState era -> UtxoEnv era
UtxoEnv
                  (Word64 -> SlotNo
SlotNo Word64
0)
                  PParams ShelleyEra
forall era. EraPParams era => PParams era
initPParams
                  CertState ShelleyEra
ShelleyCertState ShelleyEra
forall a. Default a => a
def
              , State (ShelleyUTXOW ShelleyEra)
UTxOState ShelleyEra
utxoSt
              , ShelleyTx ShelleyEra
Signal (ShelleyUTXOW ShelleyEra)
tx
              )
          )