{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Shelley.Scripts (
  MultiSig,
  ShelleyEraScript (..),
  pattern RequireSignature,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  evalMultiSig,
  validateMultiSig,
  ScriptHash (..),
  nativeMultiSigTag,
  eqMultiSigRaw,
  MultiSigRaw,
)
where

import Cardano.Crypto.Hash.Class (HashAlgorithm)
import Cardano.Ledger.BaseTypes (invalidKey)
import Cardano.Ledger.Binary (
  Annotator (..),
  DecCBOR (decCBOR),
  EncCBOR (..),
  ToCBOR,
  decodeRecordSum,
 )
import Cardano.Ledger.Binary.Coders (Encode (..), (!>))
import Cardano.Ledger.Core
import Cardano.Ledger.Crypto (Crypto, HASH, StandardCrypto)
import Cardano.Ledger.Keys (KeyHash (..), KeyRole (Witness))
import Cardano.Ledger.Keys.WitVKey (witVKeyHash)
import Cardano.Ledger.MemoBytes (
  EqRaw (..),
  Mem,
  MemoBytes,
  Memoized (..),
  getMemoRawType,
  memoBytes,
  pattern Memo,
 )
import Cardano.Ledger.SafeHash (SafeToHash (..))
import Cardano.Ledger.Shelley.Era
import Control.DeepSeq (NFData)
import qualified Data.ByteString as BS
import Data.Sequence.Strict (StrictSeq (..))
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Lens.Micro
import NoThunks.Class (NoThunks (..))

-- | A simple language for expressing conditions under which it is valid to
-- withdraw from a normal UTxO payment address or to use a stake address.
--
-- The use case is for expressing multi-signature payment addresses and
-- multi-signature stake addresses. These can be combined arbitrarily using
-- logical operations:
--
-- * multi-way \"and\";
-- * multi-way \"or\";
-- * multi-way \"N of M\".
--
-- This makes it easy to express multi-signature addresses, and provides an
-- extension point to express other validity conditions, e.g., as needed for
-- locking funds used with lightning.
data MultiSigRaw era
  = -- | Require the redeeming transaction be witnessed by the spending key
    --   corresponding to the given verification key hash.
    RequireSignature' !(KeyHash 'Witness (EraCrypto era))
  | -- | Require all the sub-terms to be satisfied.
    RequireAllOf' !(StrictSeq (MultiSig era))
  | -- | Require any one of the sub-terms to be satisfied.
    RequireAnyOf' !(StrictSeq (MultiSig era))
  | -- | Require M of the given sub-terms to be satisfied.
    RequireMOf' !Int !(StrictSeq (MultiSig era))
  deriving (MultiSigRaw era -> MultiSigRaw era -> Bool
forall era. MultiSigRaw era -> MultiSigRaw era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MultiSigRaw era -> MultiSigRaw era -> Bool
$c/= :: forall era. MultiSigRaw era -> MultiSigRaw era -> Bool
== :: MultiSigRaw era -> MultiSigRaw era -> Bool
$c== :: forall era. MultiSigRaw era -> MultiSigRaw era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (MultiSigRaw era) x -> MultiSigRaw era
forall era x. MultiSigRaw era -> Rep (MultiSigRaw era) x
$cto :: forall era x. Rep (MultiSigRaw era) x -> MultiSigRaw era
$cfrom :: forall era x. MultiSigRaw era -> Rep (MultiSigRaw era) x
Generic)
  deriving anyclass (forall era.
Typeable era =>
Context -> MultiSigRaw era -> IO (Maybe ThunkInfo)
forall era. Typeable era => Proxy (MultiSigRaw era) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (MultiSigRaw era) -> String
$cshowTypeOf :: forall era. Typeable era => Proxy (MultiSigRaw era) -> String
wNoThunks :: Context -> MultiSigRaw era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era.
Typeable era =>
Context -> MultiSigRaw era -> IO (Maybe ThunkInfo)
noThunks :: Context -> MultiSigRaw era -> IO (Maybe ThunkInfo)
$cnoThunks :: forall era.
Typeable era =>
Context -> MultiSigRaw era -> IO (Maybe ThunkInfo)
NoThunks)

class EraScript era => ShelleyEraScript era where
  mkRequireSignature :: KeyHash 'Witness (EraCrypto era) -> NativeScript era
  getRequireSignature :: NativeScript era -> Maybe (KeyHash 'Witness (EraCrypto era))

  mkRequireAllOf :: StrictSeq (NativeScript era) -> NativeScript era
  getRequireAllOf :: NativeScript era -> Maybe (StrictSeq (NativeScript era))

  mkRequireAnyOf :: StrictSeq (NativeScript era) -> NativeScript era
  getRequireAnyOf :: NativeScript era -> Maybe (StrictSeq (NativeScript era))

  mkRequireMOf :: Int -> StrictSeq (NativeScript era) -> NativeScript era
  getRequireMOf :: NativeScript era -> Maybe (Int, StrictSeq (NativeScript era))

deriving instance HashAlgorithm (HASH (EraCrypto era)) => Show (MultiSigRaw era)

instance NFData (MultiSigRaw era)

newtype MultiSig era = MultiSigConstr (MemoBytes MultiSigRaw era)
  deriving (MultiSig era -> MultiSig era -> Bool
forall era. MultiSig era -> MultiSig era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MultiSig era -> MultiSig era -> Bool
$c/= :: forall era. MultiSig era -> MultiSig era -> Bool
== :: MultiSig era -> MultiSig era -> Bool
$c== :: forall era. MultiSig era -> MultiSig era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (MultiSig era) x -> MultiSig era
forall era x. MultiSig era -> Rep (MultiSig era) x
$cto :: forall era x. Rep (MultiSig era) x -> MultiSig era
$cfrom :: forall era x. MultiSig era -> Rep (MultiSig era) x
Generic)
  deriving newtype (MultiSig era -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [MultiSig era] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (MultiSig era) -> Size
forall {era}. Typeable era => Typeable (MultiSig era)
forall era. Typeable era => MultiSig era -> Encoding
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> ToCBOR a
forall era.
Typeable era =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [MultiSig era] -> Size
forall era.
Typeable era =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (MultiSig era) -> Size
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [MultiSig era] -> Size
$cencodedListSizeExpr :: forall era.
Typeable era =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [MultiSig era] -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (MultiSig era) -> Size
$cencodedSizeExpr :: forall era.
Typeable era =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (MultiSig era) -> Size
toCBOR :: MultiSig era -> Encoding
$ctoCBOR :: forall era. Typeable era => MultiSig era -> Encoding
ToCBOR, Context -> MultiSig era -> IO (Maybe ThunkInfo)
Proxy (MultiSig era) -> String
forall era.
Typeable era =>
Context -> MultiSig era -> IO (Maybe ThunkInfo)
forall era. Typeable era => Proxy (MultiSig era) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (MultiSig era) -> String
$cshowTypeOf :: forall era. Typeable era => Proxy (MultiSig era) -> String
wNoThunks :: Context -> MultiSig era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era.
Typeable era =>
Context -> MultiSig era -> IO (Maybe ThunkInfo)
noThunks :: Context -> MultiSig era -> IO (Maybe ThunkInfo)
$cnoThunks :: forall era.
Typeable era =>
Context -> MultiSig era -> IO (Maybe ThunkInfo)
NoThunks, MultiSig era -> Int
MultiSig era -> ByteString
forall era. MultiSig era -> Int
forall era. MultiSig era -> ByteString
forall t.
(t -> ByteString)
-> (t -> Int)
-> (forall c index.
    HashAlgorithm (HASH c) =>
    Proxy c -> Proxy index -> t -> SafeHash c index)
-> SafeToHash t
forall c index.
HashAlgorithm (HASH c) =>
Proxy c -> Proxy index -> MultiSig era -> SafeHash c index
forall era c index.
HashAlgorithm (HASH c) =>
Proxy c -> Proxy index -> MultiSig era -> SafeHash c index
makeHashWithExplicitProxys :: forall c index.
HashAlgorithm (HASH c) =>
Proxy c -> Proxy index -> MultiSig era -> SafeHash c index
$cmakeHashWithExplicitProxys :: forall era c index.
HashAlgorithm (HASH c) =>
Proxy c -> Proxy index -> MultiSig era -> SafeHash c index
originalBytesSize :: MultiSig era -> Int
$coriginalBytesSize :: forall era. MultiSig era -> Int
originalBytes :: MultiSig era -> ByteString
$coriginalBytes :: forall era. MultiSig era -> ByteString
SafeToHash)

instance Memoized MultiSig where
  type RawType MultiSig = MultiSigRaw

deriving instance HashAlgorithm (HASH (EraCrypto era)) => Show (MultiSig era)

-- | Magic number "memorialized" in the ValidateScript class under the method:
--   scriptPrefixTag:: Core.Script era -> Bs.ByteString, for the Shelley Era.
nativeMultiSigTag :: BS.ByteString
nativeMultiSigTag :: ByteString
nativeMultiSigTag = ByteString
"\00"

instance Crypto c => EraScript (ShelleyEra c) where
  type Script (ShelleyEra c) = MultiSig (ShelleyEra c)
  type NativeScript (ShelleyEra c) = MultiSig (ShelleyEra c)

  -- Calling this partial function will result in compilation error, since ByronEra has
  -- no instance for EraScript type class.
  upgradeScript :: EraScript (PreviousEra (ShelleyEra c)) =>
Script (PreviousEra (ShelleyEra c)) -> Script (ShelleyEra c)
upgradeScript = forall a. HasCallStack => String -> a
error String
"It is not possible to translate a script with 'upgradeScript' from Byron era"

  getNativeScript :: Script (ShelleyEra c) -> Maybe (NativeScript (ShelleyEra c))
getNativeScript = forall a. a -> Maybe a
Just

  fromNativeScript :: NativeScript (ShelleyEra c) -> Script (ShelleyEra c)
fromNativeScript = forall a. a -> a
id

  -- In the ShelleyEra there is only one kind of Script and its tag is "\x00"
  scriptPrefixTag :: Script (ShelleyEra c) -> ByteString
scriptPrefixTag Script (ShelleyEra c)
_script = ByteString
nativeMultiSigTag

instance Crypto c => ShelleyEraScript (ShelleyEra c) where
  {-# SPECIALIZE instance ShelleyEraScript (ShelleyEra StandardCrypto) #-}

  mkRequireSignature :: KeyHash 'Witness (EraCrypto (ShelleyEra c))
-> NativeScript (ShelleyEra c)
mkRequireSignature KeyHash 'Witness (EraCrypto (ShelleyEra c))
kh =
    forall era. MemoBytes MultiSigRaw era -> MultiSig era
MultiSigConstr forall a b. (a -> b) -> a -> b
$ forall era (w :: Wrapped) (t :: * -> *).
Era era =>
Encode w (t era) -> MemoBytes t era
memoBytes (forall t. t -> Word -> Encode 'Open t
Sum forall era. KeyHash 'Witness (EraCrypto era) -> MultiSigRaw era
RequireSignature' Word
0 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To KeyHash 'Witness (EraCrypto (ShelleyEra c))
kh)
  getRequireSignature :: NativeScript (ShelleyEra c)
-> Maybe (KeyHash 'Witness (EraCrypto (ShelleyEra c)))
getRequireSignature (MultiSigConstr (Memo (RequireSignature' KeyHash 'Witness (EraCrypto (ShelleyEra c))
kh) ShortByteString
_)) = forall a. a -> Maybe a
Just KeyHash 'Witness (EraCrypto (ShelleyEra c))
kh
  getRequireSignature NativeScript (ShelleyEra c)
_ = forall a. Maybe a
Nothing

  mkRequireAllOf :: StrictSeq (NativeScript (ShelleyEra c))
-> NativeScript (ShelleyEra c)
mkRequireAllOf StrictSeq (NativeScript (ShelleyEra c))
ms =
    forall era. MemoBytes MultiSigRaw era -> MultiSig era
MultiSigConstr forall a b. (a -> b) -> a -> b
$ forall era (w :: Wrapped) (t :: * -> *).
Era era =>
Encode w (t era) -> MemoBytes t era
memoBytes (forall t. t -> Word -> Encode 'Open t
Sum forall era. StrictSeq (MultiSig era) -> MultiSigRaw era
RequireAllOf' Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictSeq (NativeScript (ShelleyEra c))
ms)
  getRequireAllOf :: NativeScript (ShelleyEra c)
-> Maybe (StrictSeq (NativeScript (ShelleyEra c)))
getRequireAllOf (MultiSigConstr (Memo (RequireAllOf' StrictSeq (MultiSig (ShelleyEra c))
ms) ShortByteString
_)) = forall a. a -> Maybe a
Just StrictSeq (MultiSig (ShelleyEra c))
ms
  getRequireAllOf NativeScript (ShelleyEra c)
_ = forall a. Maybe a
Nothing

  mkRequireAnyOf :: StrictSeq (NativeScript (ShelleyEra c))
-> NativeScript (ShelleyEra c)
mkRequireAnyOf StrictSeq (NativeScript (ShelleyEra c))
ms =
    forall era. MemoBytes MultiSigRaw era -> MultiSig era
MultiSigConstr forall a b. (a -> b) -> a -> b
$ forall era (w :: Wrapped) (t :: * -> *).
Era era =>
Encode w (t era) -> MemoBytes t era
memoBytes (forall t. t -> Word -> Encode 'Open t
Sum forall era. StrictSeq (MultiSig era) -> MultiSigRaw era
RequireAnyOf' Word
2 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictSeq (NativeScript (ShelleyEra c))
ms)
  getRequireAnyOf :: NativeScript (ShelleyEra c)
-> Maybe (StrictSeq (NativeScript (ShelleyEra c)))
getRequireAnyOf (MultiSigConstr (Memo (RequireAnyOf' StrictSeq (MultiSig (ShelleyEra c))
ms) ShortByteString
_)) = forall a. a -> Maybe a
Just StrictSeq (MultiSig (ShelleyEra c))
ms
  getRequireAnyOf NativeScript (ShelleyEra c)
_ = forall a. Maybe a
Nothing

  mkRequireMOf :: Int
-> StrictSeq (NativeScript (ShelleyEra c))
-> NativeScript (ShelleyEra c)
mkRequireMOf Int
n StrictSeq (NativeScript (ShelleyEra c))
ms =
    forall era. MemoBytes MultiSigRaw era -> MultiSig era
MultiSigConstr forall a b. (a -> b) -> a -> b
$ forall era (w :: Wrapped) (t :: * -> *).
Era era =>
Encode w (t era) -> MemoBytes t era
memoBytes (forall t. t -> Word -> Encode 'Open t
Sum forall era. Int -> StrictSeq (MultiSig era) -> MultiSigRaw era
RequireMOf' Word
3 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Int
n forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictSeq (NativeScript (ShelleyEra c))
ms)
  getRequireMOf :: NativeScript (ShelleyEra c)
-> Maybe (Int, StrictSeq (NativeScript (ShelleyEra c)))
getRequireMOf (MultiSigConstr (Memo (RequireMOf' Int
n StrictSeq (MultiSig (ShelleyEra c))
ms) ShortByteString
_)) = forall a. a -> Maybe a
Just (Int
n, StrictSeq (MultiSig (ShelleyEra c))
ms)
  getRequireMOf NativeScript (ShelleyEra c)
_ = forall a. Maybe a
Nothing

deriving newtype instance NFData (MultiSig era)

deriving via
  Mem MultiSigRaw era
  instance
    Era era => DecCBOR (Annotator (MultiSig era))

instance EqRaw (MultiSig era) where
  eqRaw :: MultiSig era -> MultiSig era -> Bool
eqRaw = forall era. MultiSig era -> MultiSig era -> Bool
eqMultiSigRaw

pattern RequireSignature ::
  ShelleyEraScript era => KeyHash 'Witness (EraCrypto era) -> NativeScript era
pattern $bRequireSignature :: forall era.
ShelleyEraScript era =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
$mRequireSignature :: forall {r} {era}.
ShelleyEraScript era =>
NativeScript era
-> (KeyHash 'Witness (EraCrypto era) -> r) -> ((# #) -> r) -> r
RequireSignature akh <- (getRequireSignature -> Just akh)
  where
    RequireSignature KeyHash 'Witness (EraCrypto era)
akh = forall era.
ShelleyEraScript era =>
KeyHash 'Witness (EraCrypto era) -> NativeScript era
mkRequireSignature KeyHash 'Witness (EraCrypto era)
akh

pattern RequireAllOf :: ShelleyEraScript era => StrictSeq (NativeScript era) -> NativeScript era
pattern $bRequireAllOf :: forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
$mRequireAllOf :: forall {r} {era}.
ShelleyEraScript era =>
NativeScript era
-> (StrictSeq (NativeScript era) -> r) -> ((# #) -> r) -> r
RequireAllOf ms <- (getRequireAllOf -> Just ms)
  where
    RequireAllOf StrictSeq (NativeScript era)
ms = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
mkRequireAllOf StrictSeq (NativeScript era)
ms

pattern RequireAnyOf :: ShelleyEraScript era => StrictSeq (NativeScript era) -> NativeScript era
pattern $bRequireAnyOf :: forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
$mRequireAnyOf :: forall {r} {era}.
ShelleyEraScript era =>
NativeScript era
-> (StrictSeq (NativeScript era) -> r) -> ((# #) -> r) -> r
RequireAnyOf ms <- (getRequireAnyOf -> Just ms)
  where
    RequireAnyOf StrictSeq (NativeScript era)
ms = forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
mkRequireAnyOf StrictSeq (NativeScript era)
ms

pattern RequireMOf ::
  ShelleyEraScript era => Int -> StrictSeq (NativeScript era) -> NativeScript era
pattern $bRequireMOf :: forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
$mRequireMOf :: forall {r} {era}.
ShelleyEraScript era =>
NativeScript era
-> (Int -> StrictSeq (NativeScript era) -> r) -> ((# #) -> r) -> r
RequireMOf n ms <- (getRequireMOf -> Just (n, ms))
  where
    RequireMOf Int
n StrictSeq (NativeScript era)
ms = forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
mkRequireMOf Int
n StrictSeq (NativeScript era)
ms

-- | Encodes memoized bytes created upon construction.
instance Era era => EncCBOR (MultiSig era)

instance Era era => DecCBOR (Annotator (MultiSigRaw era)) where
  decCBOR :: forall s. Decoder s (Annotator (MultiSigRaw era))
decCBOR = forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
"MultiSig" forall a b. (a -> b) -> a -> b
$
    \case
      Word
0 -> (,) Int
2 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. KeyHash 'Witness (EraCrypto era) -> MultiSigRaw era
RequireSignature' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (discriminator :: KeyRole) c.
Hash (ADDRHASH c) (VerKeyDSIGN (DSIGN c))
-> KeyHash discriminator c
KeyHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word
1 -> do
        Annotator (StrictSeq (MultiSig era))
multiSigs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era. StrictSeq (MultiSig era) -> MultiSigRaw era
RequireAllOf' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator (StrictSeq (MultiSig era))
multiSigs)
      Word
2 -> do
        Annotator (StrictSeq (MultiSig era))
multiSigs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
2, forall era. StrictSeq (MultiSig era) -> MultiSigRaw era
RequireAnyOf' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator (StrictSeq (MultiSig era))
multiSigs)
      Word
3 -> do
        Int
m <- forall a s. DecCBOR a => Decoder s a
decCBOR
        Annotator (StrictSeq (MultiSig era))
multiSigs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
3, forall era. Int -> StrictSeq (MultiSig era) -> MultiSigRaw era
RequireMOf' Int
m forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator (StrictSeq (MultiSig era))
multiSigs)
      Word
k -> forall (m :: * -> *) a. MonadFail m => Word -> m a
invalidKey Word
k

-- | Check the equality of two underlying types, while ignoring their binary
-- representation, which `Eq` instance normally does. This is used for testing.
eqMultiSigRaw :: MultiSig era -> MultiSig era -> Bool
eqMultiSigRaw :: forall era. MultiSig era -> MultiSig era -> Bool
eqMultiSigRaw MultiSig era
t1 MultiSig era
t2 = forall era. MultiSigRaw era -> MultiSigRaw era -> Bool
go (forall (t :: * -> *) era. Memoized t => t era -> RawType t era
getMemoRawType MultiSig era
t1) (forall (t :: * -> *) era. Memoized t => t era -> RawType t era
getMemoRawType MultiSig era
t2)
  where
    seqEq :: StrictSeq (MultiSig era) -> StrictSeq (MultiSig era) -> Bool
seqEq StrictSeq (MultiSig era)
Empty StrictSeq (MultiSig era)
Empty = Bool
True
    seqEq (MultiSig era
x :<| StrictSeq (MultiSig era)
xs) (MultiSig era
y :<| StrictSeq (MultiSig era)
ys) = forall era. MultiSig era -> MultiSig era -> Bool
eqMultiSigRaw MultiSig era
x MultiSig era
y Bool -> Bool -> Bool
&& StrictSeq (MultiSig era) -> StrictSeq (MultiSig era) -> Bool
seqEq StrictSeq (MultiSig era)
xs StrictSeq (MultiSig era)
ys
    seqEq StrictSeq (MultiSig era)
_ StrictSeq (MultiSig era)
_ = Bool
False
    go :: MultiSigRaw era -> MultiSigRaw era -> Bool
go (RequireSignature' KeyHash 'Witness (EraCrypto era)
kh1) (RequireSignature' KeyHash 'Witness (EraCrypto era)
kh2) = KeyHash 'Witness (EraCrypto era)
kh1 forall a. Eq a => a -> a -> Bool
== KeyHash 'Witness (EraCrypto era)
kh2
    go (RequireAllOf' StrictSeq (MultiSig era)
ts1) (RequireAllOf' StrictSeq (MultiSig era)
ts2) = forall {era}.
StrictSeq (MultiSig era) -> StrictSeq (MultiSig era) -> Bool
seqEq StrictSeq (MultiSig era)
ts1 StrictSeq (MultiSig era)
ts2
    go (RequireAnyOf' StrictSeq (MultiSig era)
ts1) (RequireAnyOf' StrictSeq (MultiSig era)
ts2) = forall {era}.
StrictSeq (MultiSig era) -> StrictSeq (MultiSig era) -> Bool
seqEq StrictSeq (MultiSig era)
ts1 StrictSeq (MultiSig era)
ts2
    go (RequireMOf' Int
n1 StrictSeq (MultiSig era)
ts1) (RequireMOf' Int
n2 StrictSeq (MultiSig era)
ts2) = Int
n1 forall a. Eq a => a -> a -> Bool
== Int
n2 Bool -> Bool -> Bool
&& forall {era}.
StrictSeq (MultiSig era) -> StrictSeq (MultiSig era) -> Bool
seqEq StrictSeq (MultiSig era)
ts1 StrictSeq (MultiSig era)
ts2
    go MultiSigRaw era
_ MultiSigRaw era
_ = Bool
False

-- | Script evaluator for native multi-signature scheme. 'vhks' is the set of
-- key hashes that signed the transaction to be validated.
evalMultiSig ::
  (ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
  Set.Set (KeyHash 'Witness (EraCrypto era)) ->
  NativeScript era ->
  Bool
evalMultiSig :: forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
Set (KeyHash 'Witness (EraCrypto era)) -> NativeScript era -> Bool
evalMultiSig Set (KeyHash 'Witness (EraCrypto era))
vhks = NativeScript era -> Bool
go
  where
    -- The important part of this validator is that it will stop as soon as it reaches the
    -- required number of valid scripts
    isValidMOf :: Int -> StrictSeq (NativeScript era) -> Bool
isValidMOf Int
n StrictSeq (NativeScript era)
StrictSeq.Empty = Int
n forall a. Ord a => a -> a -> Bool
<= Int
0
    isValidMOf Int
n (NativeScript era
msig StrictSeq.:<| StrictSeq (NativeScript era)
msigs) =
      Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| if NativeScript era -> Bool
go NativeScript era
msig then Int -> StrictSeq (NativeScript era) -> Bool
isValidMOf (Int
n forall a. Num a => a -> a -> a
- Int
1) StrictSeq (NativeScript era)
msigs else Int -> StrictSeq (NativeScript era) -> Bool
isValidMOf Int
n StrictSeq (NativeScript era)
msigs
    go :: NativeScript era -> Bool
go = \case
      RequireSignature KeyHash 'Witness (EraCrypto era)
hk -> forall a. Ord a => a -> Set a -> Bool
Set.member KeyHash 'Witness (EraCrypto era)
hk Set (KeyHash 'Witness (EraCrypto era))
vhks
      RequireAllOf StrictSeq (NativeScript era)
msigs -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all NativeScript era -> Bool
go StrictSeq (NativeScript era)
msigs
      RequireAnyOf StrictSeq (NativeScript era)
msigs -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NativeScript era -> Bool
go StrictSeq (NativeScript era)
msigs
      RequireMOf Int
m StrictSeq (NativeScript era)
msigs -> Int -> StrictSeq (NativeScript era) -> Bool
isValidMOf Int
m StrictSeq (NativeScript era)
msigs
      NativeScript era
_ -> forall a. HasCallStack => String -> a
error String
"Impossible: All NativeScripts should have been accounted for"

-- | Script validator for native multi-signature scheme.
validateMultiSig ::
  (ShelleyEraScript era, EraTx era, NativeScript era ~ MultiSig era) =>
  Tx era ->
  NativeScript era ->
  Bool
validateMultiSig :: forall era.
(ShelleyEraScript era, EraTx era,
 NativeScript era ~ MultiSig era) =>
Tx era -> NativeScript era -> Bool
validateMultiSig Tx era
tx =
  forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
Set (KeyHash 'Witness (EraCrypto era)) -> NativeScript era -> Bool
evalMultiSig forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (kr :: KeyRole) c. WitVKey kr c -> KeyHash 'Witness c
witVKeyHash (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness (EraCrypto era)))
addrTxWitsL)
{-# INLINE validateMultiSig #-}