{-# 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,
  nativeMultiSigTag,
  eqMultiSigRaw,
  MultiSigRaw,
)
where

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.Keys.WitVKey (witVKeyHash)
import Cardano.Ledger.MemoBytes (
  EqRaw (..),
  Mem,
  MemoBytes,
  Memoized (..),
  getMemoRawType,
  memoBytes,
  pattern Memo,
 )
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)
  | -- | 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, Int -> MultiSigRaw era -> ShowS
forall era. Int -> MultiSigRaw era -> ShowS
forall era. [MultiSigRaw era] -> ShowS
forall era. MultiSigRaw era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MultiSigRaw era] -> ShowS
$cshowList :: forall era. [MultiSigRaw era] -> ShowS
show :: MultiSigRaw era -> String
$cshow :: forall era. MultiSigRaw era -> String
showsPrec :: Int -> MultiSigRaw era -> ShowS
$cshowsPrec :: forall era. Int -> MultiSigRaw era -> ShowS
Show, 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 -> NativeScript era
  getRequireSignature :: NativeScript era -> Maybe (KeyHash 'Witness)

  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))

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, Int -> MultiSig era -> ShowS
forall era. Int -> MultiSig era -> ShowS
forall era. [MultiSig era] -> ShowS
forall era. MultiSig era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MultiSig era] -> ShowS
$cshowList :: forall era. [MultiSig era] -> ShowS
show :: MultiSig era -> String
$cshow :: forall era. MultiSig era -> String
showsPrec :: Int -> MultiSig era -> ShowS
$cshowsPrec :: forall era. Int -> MultiSig era -> ShowS
Show, 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 i. Proxy i -> MultiSig era -> SafeHash i
forall era. MultiSig era -> Int
forall era. MultiSig era -> ByteString
forall t.
(t -> ByteString)
-> (t -> Int)
-> (forall i. Proxy i -> t -> SafeHash i)
-> SafeToHash t
forall era i. Proxy i -> MultiSig era -> SafeHash i
makeHashWithExplicitProxys :: forall i. Proxy i -> MultiSig era -> SafeHash i
$cmakeHashWithExplicitProxys :: forall era i. Proxy i -> MultiSig era -> SafeHash i
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

-- | 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 EraScript ShelleyEra where
  type Script ShelleyEra = MultiSig ShelleyEra
  type NativeScript ShelleyEra = MultiSig ShelleyEra

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

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

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

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

instance ShelleyEraScript ShelleyEra where
  mkRequireSignature :: KeyHash 'Witness -> NativeScript ShelleyEra
mkRequireSignature KeyHash 'Witness
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 -> 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
kh)
  getRequireSignature :: NativeScript ShelleyEra -> Maybe (KeyHash 'Witness)
getRequireSignature (MultiSigConstr (Memo (RequireSignature' KeyHash 'Witness
kh) ShortByteString
_)) = forall a. a -> Maybe a
Just KeyHash 'Witness
kh
  getRequireSignature NativeScript ShelleyEra
_ = forall a. Maybe a
Nothing

  mkRequireAllOf :: StrictSeq (NativeScript ShelleyEra) -> NativeScript ShelleyEra
mkRequireAllOf StrictSeq (NativeScript ShelleyEra)
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)
ms)
  getRequireAllOf :: NativeScript ShelleyEra
-> Maybe (StrictSeq (NativeScript ShelleyEra))
getRequireAllOf (MultiSigConstr (Memo (RequireAllOf' StrictSeq (MultiSig ShelleyEra)
ms) ShortByteString
_)) = forall a. a -> Maybe a
Just StrictSeq (MultiSig ShelleyEra)
ms
  getRequireAllOf NativeScript ShelleyEra
_ = forall a. Maybe a
Nothing

  mkRequireAnyOf :: StrictSeq (NativeScript ShelleyEra) -> NativeScript ShelleyEra
mkRequireAnyOf StrictSeq (NativeScript ShelleyEra)
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)
ms)
  getRequireAnyOf :: NativeScript ShelleyEra
-> Maybe (StrictSeq (NativeScript ShelleyEra))
getRequireAnyOf (MultiSigConstr (Memo (RequireAnyOf' StrictSeq (MultiSig ShelleyEra)
ms) ShortByteString
_)) = forall a. a -> Maybe a
Just StrictSeq (MultiSig ShelleyEra)
ms
  getRequireAnyOf NativeScript ShelleyEra
_ = forall a. Maybe a
Nothing

  mkRequireMOf :: Int
-> StrictSeq (NativeScript ShelleyEra) -> NativeScript ShelleyEra
mkRequireMOf Int
n StrictSeq (NativeScript ShelleyEra)
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)
ms)
  getRequireMOf :: NativeScript ShelleyEra
-> Maybe (Int, StrictSeq (NativeScript ShelleyEra))
getRequireMOf (MultiSigConstr (Memo (RequireMOf' Int
n StrictSeq (MultiSig ShelleyEra)
ms) ShortByteString
_)) = forall a. a -> Maybe a
Just (Int
n, StrictSeq (MultiSig ShelleyEra)
ms)
  getRequireMOf NativeScript ShelleyEra
_ = 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 -> NativeScript era
pattern $bRequireSignature :: forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
$mRequireSignature :: forall {r} {era}.
ShelleyEraScript era =>
NativeScript era -> (KeyHash 'Witness -> r) -> ((# #) -> r) -> r
RequireSignature akh <- (getRequireSignature -> Just akh)
  where
    RequireSignature KeyHash 'Witness
akh = forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
mkRequireSignature KeyHash 'Witness
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 -> MultiSigRaw era
RequireSignature' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: KeyRole).
Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
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
kh1) (RequireSignature' KeyHash 'Witness
kh2) = KeyHash 'Witness
kh1 forall a. Eq a => a -> a -> Bool
== KeyHash 'Witness
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) ->
  NativeScript era ->
  Bool
evalMultiSig :: forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
Set (KeyHash 'Witness) -> NativeScript era -> Bool
evalMultiSig Set (KeyHash 'Witness)
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
hk -> forall a. Ord a => a -> Set a -> Bool
Set.member KeyHash 'Witness
hk Set (KeyHash 'Witness)
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) -> 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). WitVKey kr -> KeyHash 'Witness
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))
addrTxWitsL)
{-# INLINE validateMultiSig #-}