{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Constrained.Scripts (
  allPlutusScripts,
  genCoreScript,
  spendPlutusScripts,
  sufficientScript,
) where

import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..))
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Core (Era (..), NativeScript, Script, getNativeScript, hashScript)
import Cardano.Ledger.Hashes (ScriptHash)
import Cardano.Ledger.Keys (
  KeyHash (..),
  KeyRole (..),
 )
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Monad (replicateM)
import Data.Foldable (toList)
import qualified Data.List as List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import qualified Data.Sequence.Strict as Seq
import Data.Set (Set)
import qualified Data.Set as Set
import Numeric.Natural
import Test.Cardano.Ledger.Constrained.Combinators (genFromMap)
import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..))
import Test.Cardano.Ledger.Generic.Functions (
  alwaysFalse,
  alwaysTrue,
  primaryLanguage,
 )
import Test.Cardano.Ledger.Generic.GenState
import Test.Cardano.Ledger.Generic.Proof
import Test.QuickCheck

import Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript,
  Timelock,
  ValidityInterval (..),
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
 )
import Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  ShelleyEraScript,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )

-- ======================================

type KeyMap era = Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era))

genMultiSig ::
  forall era.
  (ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
  KeyMap era ->
  Proof era ->
  Gen (MultiSig era)
genMultiSig :: forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
KeyMap era -> Proof era -> Gen (MultiSig era)
genMultiSig KeyMap era
keymap Proof era
_proof = do
  let genNestedMultiSig :: Natural -> Gen (MultiSig era)
      genNestedMultiSig :: Natural -> Gen (MultiSig era)
genNestedMultiSig Natural
k
        | Natural
k forall a. Ord a => a -> a -> Bool
> Natural
0 =
            forall a. HasCallStack => [Gen a] -> Gen a
oneof forall a b. (a -> b) -> a -> b
$
              [Gen (MultiSig era)]
nonRecTimelocks forall a. [a] -> [a] -> [a]
++ [Natural -> Gen (MultiSig era)
requireAllOf Natural
k, Natural -> Gen (MultiSig era)
requireAnyOf Natural
k, Natural -> Gen (MultiSig era)
requireMOf Natural
k]
        | Bool
otherwise = forall a. HasCallStack => [Gen a] -> Gen a
oneof [Gen (MultiSig era)]
nonRecTimelocks
      nonRecTimelocks :: [Gen (MultiSig era)]
nonRecTimelocks = [Gen (MultiSig era)
requireSignature]
      requireSignature :: Gen (MultiSig era)
requireSignature =
        forall era.
ShelleyEraScript era =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
RequireSignature @era forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. [String] -> Map k a -> Gen (k, a)
genFromMap [String
"from requiresSignature in genMultiSig"] KeyMap era
keymap
      requireAllOf :: Natural -> Gen (MultiSig era)
requireAllOf Natural
k = do
        Int
n <- Gen Int
nonNegativeSingleDigitInt
        forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> Gen (MultiSig era)
genNestedMultiSig (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
      requireAnyOf :: Natural -> Gen (MultiSig era)
requireAnyOf Natural
k = do
        Int
n <- Gen Int
positiveSingleDigitInt
        forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> Gen (MultiSig era)
genNestedMultiSig (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
      requireMOf :: Natural -> Gen (MultiSig era)
requireMOf Natural
k = do
        Int
n <- Gen Int
nonNegativeSingleDigitInt
        Int
m <- forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n)
        forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> Gen (MultiSig era)
genNestedMultiSig (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
  Natural -> Gen (MultiSig era)
genNestedMultiSig (Natural
2 :: Natural)

genTimelock ::
  forall era.
  (AllegraEraScript era, NativeScript era ~ Timelock era) =>
  KeyMap era ->
  ValidityInterval ->
  Proof era ->
  Gen (Timelock era)
genTimelock :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyMap era -> ValidityInterval -> Proof era -> Gen (Timelock era)
genTimelock KeyMap era
keymap (ValidityInterval StrictMaybe SlotNo
mBefore StrictMaybe SlotNo
mAfter) Proof era
_proof = do
  -- We need to limit how deep these timelocks can go, otherwise this generator will
  -- diverge. It also has to stay very shallow because it grows too fast.
  let genNestedTimelock :: Natural -> Gen (Timelock era)
genNestedTimelock Natural
k
        | Natural
k forall a. Ord a => a -> a -> Bool
> Natural
0 =
            forall a. HasCallStack => [Gen a] -> Gen a
oneof forall a b. (a -> b) -> a -> b
$
              [Gen (Timelock era)]
nonRecTimelocks forall a. [a] -> [a] -> [a]
++ [Natural -> Gen (Timelock era)
requireAllOf Natural
k, Natural -> Gen (Timelock era)
requireAnyOf Natural
k, Natural -> Gen (Timelock era)
requireMOf Natural
k]
        | Bool
otherwise = forall a. HasCallStack => [Gen a] -> Gen a
oneof [Gen (Timelock era)]
nonRecTimelocks
      nonRecTimelocks :: [Gen (Timelock era)]
      nonRecTimelocks :: [Gen (Timelock era)]
nonRecTimelocks =
        [ Gen (Timelock era)
r
        | SJust Gen (Timelock era)
r <-
            [ forall {era}.
AllegraEraScript era =>
SlotNo -> Gen (NativeScript era)
requireTimeStart forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe SlotNo
mBefore
            , forall {era}.
AllegraEraScript era =>
SlotNo -> Gen (NativeScript era)
requireTimeExpire forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictMaybe SlotNo
mAfter
            , forall a. a -> StrictMaybe a
SJust Gen (Timelock era)
requireSignature
            ]
        ]
      requireSignature :: Gen (Timelock era)
requireSignature = forall era.
ShelleyEraScript era =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
RequireSignature forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. [String] -> Map k a -> Gen (k, a)
genFromMap [String
"from requiresSignature in genTimelock"] KeyMap era
keymap
      requireAllOf :: Natural -> Gen (Timelock era)
requireAllOf Natural
k = do
        Int
n <- Gen Int
nonNegativeSingleDigitInt
        forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> Gen (Timelock era)
genNestedTimelock (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
      requireAnyOf :: Natural -> Gen (Timelock era)
requireAnyOf Natural
k = do
        Int
n <- Gen Int
positiveSingleDigitInt
        forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> Gen (Timelock era)
genNestedTimelock (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
      requireMOf :: Natural -> Gen (Timelock era)
requireMOf Natural
k = do
        Int
n <- Gen Int
nonNegativeSingleDigitInt
        Int
m <- forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n)
        forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> StrictSeq a
Seq.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Natural -> Gen (Timelock era)
genNestedTimelock (Natural
k forall a. Num a => a -> a -> a
- Natural
1))
      requireTimeStart :: SlotNo -> Gen (NativeScript era)
requireTimeStart (SlotNo Word64
validFrom) = do
        Word64
minSlotNo <- forall a. Random a => (a, a) -> Gen a
choose (forall a. Bounded a => a
minBound, Word64
validFrom)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeStart (Word64 -> SlotNo
SlotNo Word64
minSlotNo)
      requireTimeExpire :: SlotNo -> Gen (NativeScript era)
requireTimeExpire (SlotNo Word64
validTill) = do
        Word64
maxSlotNo <- forall a. Random a => (a, a) -> Gen a
choose (Word64
validTill, forall a. Bounded a => a
maxBound)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era. AllegraEraScript era => SlotNo -> NativeScript era
RequireTimeExpire (Word64 -> SlotNo
SlotNo Word64
maxSlotNo)
  Natural -> Gen (Timelock era)
genNestedTimelock (Natural
2 :: Natural)

genPlutusScript ::
  forall era.
  PlutusPurposeTag ->
  Proof era ->
  Gen (Bool, Script era)
genPlutusScript :: forall era. PlutusPurposeTag -> Proof era -> Gen (Bool, Script era)
genPlutusScript PlutusPurposeTag
tag Proof era
proof = do
  Bool
isValid <- forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
5, forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False), (Int
95, forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)]
  -- Plutus scripts alwaysSucceeds needs at least numArgs, while
  -- alwaysFails needs exactly numArgs to have the desired affect.
  -- For reasons unknown, this number differs from Alonzo to Babbage
  -- Perhaps because Babbage is using PlutusV2 scripts?
  let numArgs :: Natural
numArgs = case (Proof era
proof, PlutusPurposeTag
tag) of
        (Proof era
Conway, PlutusPurposeTag
Spending) -> Natural
2
        (Proof era
Conway, PlutusPurposeTag
_) -> Natural
1
        (Proof era
Babbage, PlutusPurposeTag
Spending) -> Natural
2
        (Proof era
Babbage, PlutusPurposeTag
_) -> Natural
1
        (Proof era
_, PlutusPurposeTag
Spending) -> Natural
3
        (Proof era
_, PlutusPurposeTag
_) -> Natural
2
  -- While using varying number of arguments for alwaysSucceeds we get
  -- varying script hashes, which helps with the fuzziness
  let mlanguage :: Maybe Language
mlanguage = forall era. Proof era -> Maybe Language
primaryLanguage Proof era
proof
  if Bool
isValid
    then (,) Bool
isValid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. Proof era -> Maybe Language -> Natural -> Script era
alwaysTrue Proof era
proof Maybe Language
mlanguage forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ Natural
numArgs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. HasCallStack => [a] -> Gen a
elements [Natural
0, Natural
1, Natural
2, Natural
3 :: Natural])
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Bool
isValid, forall era. Proof era -> Maybe Language -> Natural -> Script era
alwaysFalse Proof era
proof Maybe Language
mlanguage Natural
numArgs)

genCoreScript ::
  forall era.
  Proof era ->
  PlutusPurposeTag ->
  KeyMap era ->
  ValidityInterval ->
  Gen (Script era)
genCoreScript :: forall era.
Proof era
-> PlutusPurposeTag
-> KeyMap era
-> ValidityInterval
-> Gen (Script era)
genCoreScript Proof era
proof PlutusPurposeTag
tag KeyMap era
keymap ValidityInterval
vi = case Proof era
proof of
  Proof era
Conway ->
    forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, forall era. Timelock era -> AlonzoScript era
TimelockScript forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyMap era -> ValidityInterval -> Proof era -> Gen (Timelock era)
genTimelock KeyMap era
keymap ValidityInterval
vi Proof era
proof)
      -- TODO Add this once scripts are working in Conway
      -- , (1, snd <$> genPlutusScript tag proof)
      ]
  Proof era
Babbage ->
    forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, forall era. Timelock era -> AlonzoScript era
TimelockScript forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyMap era -> ValidityInterval -> Proof era -> Gen (Timelock era)
genTimelock KeyMap era
keymap ValidityInterval
vi Proof era
proof)
      , (Int
1, forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. PlutusPurposeTag -> Proof era -> Gen (Bool, Script era)
genPlutusScript PlutusPurposeTag
tag Proof era
proof)
      ]
  Proof era
Alonzo ->
    forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
      [ (Int
1, forall era. Timelock era -> AlonzoScript era
TimelockScript forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyMap era -> ValidityInterval -> Proof era -> Gen (Timelock era)
genTimelock KeyMap era
keymap ValidityInterval
vi Proof era
proof)
      , (Int
1, forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. PlutusPurposeTag -> Proof era -> Gen (Bool, Script era)
genPlutusScript PlutusPurposeTag
tag Proof era
proof)
      ]
  Proof era
Mary -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyMap era -> ValidityInterval -> Proof era -> Gen (Timelock era)
genTimelock KeyMap era
keymap ValidityInterval
vi Proof era
proof
  Proof era
Allegra -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
KeyMap era -> ValidityInterval -> Proof era -> Gen (Timelock era)
genTimelock KeyMap era
keymap ValidityInterval
vi Proof era
proof
  Proof era
Shelley -> forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
KeyMap era -> Proof era -> Gen (MultiSig era)
genMultiSig KeyMap era
keymap Proof era
proof

-- | For any given Era, there are only a finite number of Plutus scripts.
--   This function computes all of them. There will be two failing scripts
--   One for the Spend Tag, and another for all other Tags (Mint, Cert, Rewrd).
--   The non-failing Spend scripts have varying number of arguments (0, 1, 2, 3)
--   The non-failing (Mint Cert Rewrd) scripts are identical.
--   Any Plutus script generated by 'genCoreScript' will be in this Map.
allPlutusScripts ::
  Reflect era => Proof era -> Map (ScriptHash (EraCrypto era)) (IsValid, Script era)
allPlutusScripts :: forall era.
Reflect era =>
Proof era -> Map (ScriptHash (EraCrypto era)) (IsValid, Script era)
allPlutusScripts Proof era
proof =
  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 forall {era} {a}.
EraScript era =>
(a, Script era) -> (ScriptHash (EraCrypto era), (a, Script era))
hash (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall era.
Proof era -> PlutusPurposeTag -> [(IsValid, Script era)]
plutusByTag Proof era
proof) (forall era. Proof era -> [PlutusPurposeTag]
plutusPurposeTags Proof era
proof))
  where
    hash :: (a, Script era) -> (ScriptHash (EraCrypto era), (a, Script era))
hash (a
b, Script era
s) = (forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript Script era
s, (a
b, Script era
s))

-- | There are only 5 plutus scripts that can be used in a Spend context
spendPlutusScripts ::
  Reflect era => Proof era -> Map (ScriptHash (EraCrypto era)) (IsValid, Script era)
spendPlutusScripts :: forall era.
Reflect era =>
Proof era -> Map (ScriptHash (EraCrypto era)) (IsValid, Script era)
spendPlutusScripts Proof era
proof = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall {era} {a}.
EraScript era =>
(a, Script era) -> (ScriptHash (EraCrypto era), (a, Script era))
hash (forall era.
Proof era -> PlutusPurposeTag -> [(IsValid, Script era)]
plutusByTag Proof era
proof PlutusPurposeTag
Spending))
  where
    hash :: (a, Script era) -> (ScriptHash (EraCrypto era), (a, Script era))
hash (a
b, Script era
s) = (forall era.
EraScript era =>
Script era -> ScriptHash (EraCrypto era)
hashScript Script era
s, (a
b, Script era
s))

plutusByTag :: Proof era -> PlutusPurposeTag -> [(IsValid, Script era)]
plutusByTag :: forall era.
Proof era -> PlutusPurposeTag -> [(IsValid, Script era)]
plutusByTag Proof era
proof PlutusPurposeTag
tag = [(IsValid, Script era)]
trueS forall a. [a] -> [a] -> [a]
++ [(IsValid, Script era)]
falseS
  where
    numArgs :: Natural
numArgs = case (Proof era
proof, PlutusPurposeTag
tag) of
      (Proof era
Conway, PlutusPurposeTag
Spending) -> Natural
2
      (Proof era
Conway, PlutusPurposeTag
_) -> Natural
1
      (Proof era
Babbage, PlutusPurposeTag
Spending) -> Natural
2
      (Proof era
Babbage, PlutusPurposeTag
_) -> Natural
1
      (Proof era
_, PlutusPurposeTag
Spending) -> Natural
3
      (Proof era
_, PlutusPurposeTag
_) -> Natural
2
    trueS :: [(IsValid, Script era)]
trueS = [(Bool -> IsValid
IsValid Bool
True, forall era. Proof era -> Maybe Language -> Natural -> Script era
alwaysTrue Proof era
proof Maybe Language
mlanguage (Natural
numArgs forall a. Num a => a -> a -> a
+ Natural
n)) | Natural
n <- [Natural
0, Natural
1, Natural
2, Natural
3 :: Natural]]
    falseS :: [(IsValid, Script era)]
falseS = [(Bool -> IsValid
IsValid Bool
False, forall era. Proof era -> Maybe Language -> Natural -> Script era
alwaysFalse Proof era
proof Maybe Language
mlanguage Natural
numArgs)]
    mlanguage :: Maybe Language
mlanguage = forall era. Proof era -> Maybe Language
primaryLanguage Proof era
proof

-- ===================================================

-- The function 'witsVKeyNeededFromBody' computes the necesary (but not sufficient)
-- key witnesses. Some of the missing ones have to do with MultiSig (and Timelock) scripts
-- So we need to compute the smallest set possible for Scripts. A MultiSig (Timelock) scripts
-- needs enough key witnesses, so that some subset of the Signature scripts to make it True.

sufficientMultiSig ::
  (ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
  MultiSig era ->
  Set (KeyHash 'Witness (EraCrypto era))
sufficientMultiSig :: forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
MultiSig era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientMultiSig MultiSig era
x = case MultiSig era
x of
  RequireSignature KeyHash 'Witness (EraCrypto era)
kh -> forall a. a -> Set a
Set.singleton KeyHash 'Witness (EraCrypto era)
kh
  RequireAllOf StrictSeq (NativeScript era)
xs -> forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
MultiSig era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientMultiSig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (NativeScript era)
xs)
  RequireAnyOf StrictSeq (NativeScript era)
xs ->
    case forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy forall {a} {a}. Set a -> Set a -> Ordering
p (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null) (forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
MultiSig era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientMultiSig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (NativeScript era)
xs))) of
      [] -> forall a. Set a
Set.empty
      (Set (KeyHash 'Witness (EraCrypto era))
s : [Set (KeyHash 'Witness (EraCrypto era))]
_) -> Set (KeyHash 'Witness (EraCrypto era))
s
  RequireMOf Int
n StrictSeq (NativeScript era)
xs -> forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (forall a. Int -> [a] -> [a]
take Int
n (forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy forall {a} {a}. Set a -> Set a -> Ordering
p (forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
MultiSig era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientMultiSig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (NativeScript era)
xs))))
  MultiSig era
_ -> forall a. HasCallStack => String -> a
error String
"Impossible: All NativeScripts should have been accounted for"
  where
    p :: Set a -> Set a -> Ordering
p Set a
a Set a
b = forall a. Ord a => a -> a -> Ordering
compare (forall a. Set a -> Int
Set.size Set a
a) (forall a. Set a -> Int
Set.size Set a
b)

-- | Return sufficient KeyHash to make the Timelock succeed. Note that some Timelock
--   scripts need no KeyHashes to succeed (RequireTimeExpire, RequireTimeStart)
sufficientTimelock ::
  (AllegraEraScript era, NativeScript era ~ Timelock era) =>
  Timelock era ->
  Set (KeyHash 'Witness (EraCrypto era))
sufficientTimelock :: forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Timelock era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientTimelock Timelock era
x = case Timelock era
x of
  RequireSignature KeyHash 'Witness (EraCrypto era)
kh -> forall a. a -> Set a
Set.singleton KeyHash 'Witness (EraCrypto era)
kh
  RequireAllOf StrictSeq (NativeScript era)
xs -> forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Timelock era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientTimelock StrictSeq (NativeScript era)
xs)
  RequireAnyOf StrictSeq (NativeScript era)
xs ->
    case forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy forall {a} {a}. Set a -> Set a -> Ordering
p (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null) (forall a b. (a -> b) -> [a] -> [b]
map forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Timelock era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientTimelock (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (NativeScript era)
xs))) of
      [] -> forall a. Set a
Set.empty
      (Set (KeyHash 'Witness (EraCrypto era))
s : [Set (KeyHash 'Witness (EraCrypto era))]
_) -> Set (KeyHash 'Witness (EraCrypto era))
s
  RequireMOf Int
n StrictSeq (NativeScript era)
xs -> forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (forall a. Int -> [a] -> [a]
take Int
n (forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy forall {a} {a}. Set a -> Set a -> Ordering
p (forall a b. (a -> b) -> [a] -> [b]
map forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Timelock era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientTimelock (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList StrictSeq (NativeScript era)
xs))))
  RequireTimeExpire {} -> forall a. Set a
Set.empty
  RequireTimeStart {} -> forall a. Set a
Set.empty
  where
    p :: Set a -> Set a -> Ordering
p Set a
a Set a
b = forall a. Ord a => a -> a -> Ordering
compare (forall a. Set a -> Int
Set.size Set a
a) (forall a. Set a -> Int
Set.size Set a
b)

sufficientScript :: Proof era -> Script era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientScript :: forall era.
Proof era -> Script era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientScript Proof era
p Script era
s = case Proof era
p of
  Proof era
Shelley -> forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
MultiSig era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientMultiSig Script era
s
  Proof era
Allegra -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Timelock era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientTimelock Script era
s
  Proof era
Mary -> forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Timelock era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientTimelock Script era
s
  Proof era
Alonzo -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Set a
Set.empty forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Timelock era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientTimelock (forall era. EraScript era => Script era -> Maybe (NativeScript era)
getNativeScript Script era
s)
  Proof era
Babbage -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Set a
Set.empty forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Timelock era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientTimelock (forall era. EraScript era => Script era -> Maybe (NativeScript era)
getNativeScript Script era
s)
  Proof era
Conway -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Set a
Set.empty forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Timelock era -> Set (KeyHash 'Witness (EraCrypto era))
sufficientTimelock (forall era. EraScript era => Script era -> Maybe (NativeScript era)
getNativeScript Script era
s)