{-# 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 TypeApplications #-}
{-# 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.Binary (
  Annotator,
  DecCBOR (decCBOR),
  EncCBOR (..),
  ToCBOR,
  decodeRecordSum,
  invalidKey,
 )
import Cardano.Ledger.Binary.Coders (
  Encode (Sum, To),
  (!>),
 )
import Cardano.Ledger.Core
import Cardano.Ledger.Keys.WitVKey (witVKeyHash)
import Cardano.Ledger.MemoBytes (
  EqRaw (..),
  Mem,
  MemoBytes,
  Memoized (..),
  getMemoRawType,
  pattern Memo,
 )
import Cardano.Ledger.MemoBytes.Internal (memoBytesEra)
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.
    MultiSigSignature !(KeyHash Witness)
  | -- | Require all the sub-terms to be satisfied.
    MultiSigAllOf !(StrictSeq (MultiSig era))
  | -- | Require any one of the sub-terms to be satisfied.
    MultiSigAnyOf !(StrictSeq (MultiSig era))
  | -- | Require M of the given sub-terms to be satisfied.
    MultiSigMOf !Int !(StrictSeq (MultiSig era))
  deriving (MultiSigRaw era -> MultiSigRaw era -> Bool
(MultiSigRaw era -> MultiSigRaw era -> Bool)
-> (MultiSigRaw era -> MultiSigRaw era -> Bool)
-> Eq (MultiSigRaw era)
forall era. MultiSigRaw era -> MultiSigRaw era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era. MultiSigRaw era -> MultiSigRaw era -> Bool
== :: MultiSigRaw era -> MultiSigRaw era -> Bool
$c/= :: forall era. MultiSigRaw era -> MultiSigRaw era -> Bool
/= :: MultiSigRaw era -> MultiSigRaw era -> Bool
Eq, Int -> MultiSigRaw era -> ShowS
[MultiSigRaw era] -> ShowS
MultiSigRaw era -> String
(Int -> MultiSigRaw era -> ShowS)
-> (MultiSigRaw era -> String)
-> ([MultiSigRaw era] -> ShowS)
-> Show (MultiSigRaw era)
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
$cshowsPrec :: forall era. Int -> MultiSigRaw era -> ShowS
showsPrec :: Int -> MultiSigRaw era -> ShowS
$cshow :: forall era. MultiSigRaw era -> String
show :: MultiSigRaw era -> String
$cshowList :: forall era. [MultiSigRaw era] -> ShowS
showList :: [MultiSigRaw era] -> ShowS
Show, (forall x. MultiSigRaw era -> Rep (MultiSigRaw era) x)
-> (forall x. Rep (MultiSigRaw era) x -> MultiSigRaw era)
-> Generic (MultiSigRaw era)
forall x. Rep (MultiSigRaw era) x -> MultiSigRaw era
forall x. MultiSigRaw era -> Rep (MultiSigRaw era) x
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
$cfrom :: forall era x. MultiSigRaw era -> Rep (MultiSigRaw era) x
from :: forall x. MultiSigRaw era -> Rep (MultiSigRaw era) x
$cto :: forall era x. Rep (MultiSigRaw era) x -> MultiSigRaw era
to :: forall x. Rep (MultiSigRaw era) x -> MultiSigRaw era
Generic)
  deriving anyclass (Context -> MultiSigRaw era -> IO (Maybe ThunkInfo)
Proxy (MultiSigRaw era) -> String
(Context -> MultiSigRaw era -> IO (Maybe ThunkInfo))
-> (Context -> MultiSigRaw era -> IO (Maybe ThunkInfo))
-> (Proxy (MultiSigRaw era) -> String)
-> NoThunks (MultiSigRaw era)
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
$cnoThunks :: forall era.
Typeable era =>
Context -> MultiSigRaw era -> IO (Maybe ThunkInfo)
noThunks :: Context -> MultiSigRaw era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era.
Typeable era =>
Context -> MultiSigRaw era -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> MultiSigRaw era -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall era. Typeable era => Proxy (MultiSigRaw era) -> String
showTypeOf :: Proxy (MultiSigRaw era) -> String
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 = MkMultiSig (MemoBytes (MultiSigRaw era))
  deriving (MultiSig era -> MultiSig era -> Bool
(MultiSig era -> MultiSig era -> Bool)
-> (MultiSig era -> MultiSig era -> Bool) -> Eq (MultiSig era)
forall era. MultiSig era -> MultiSig era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era. MultiSig era -> MultiSig era -> Bool
== :: MultiSig era -> MultiSig era -> Bool
$c/= :: forall era. MultiSig era -> MultiSig era -> Bool
/= :: MultiSig era -> MultiSig era -> Bool
Eq, Int -> MultiSig era -> ShowS
[MultiSig era] -> ShowS
MultiSig era -> String
(Int -> MultiSig era -> ShowS)
-> (MultiSig era -> String)
-> ([MultiSig era] -> ShowS)
-> Show (MultiSig era)
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
$cshowsPrec :: forall era. Int -> MultiSig era -> ShowS
showsPrec :: Int -> MultiSig era -> ShowS
$cshow :: forall era. MultiSig era -> String
show :: MultiSig era -> String
$cshowList :: forall era. [MultiSig era] -> ShowS
showList :: [MultiSig era] -> ShowS
Show, (forall x. MultiSig era -> Rep (MultiSig era) x)
-> (forall x. Rep (MultiSig era) x -> MultiSig era)
-> Generic (MultiSig era)
forall x. Rep (MultiSig era) x -> MultiSig era
forall x. MultiSig era -> Rep (MultiSig era) x
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
$cfrom :: forall era x. MultiSig era -> Rep (MultiSig era) x
from :: forall x. MultiSig era -> Rep (MultiSig era) x
$cto :: forall era x. Rep (MultiSig era) x -> MultiSig era
to :: forall x. Rep (MultiSig era) x -> MultiSig era
Generic)
  deriving newtype (Typeable (MultiSig era)
Typeable (MultiSig era) =>
(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)
-> ToCBOR (MultiSig era)
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
$ctoCBOR :: forall era. Typeable era => MultiSig era -> Encoding
toCBOR :: MultiSig era -> Encoding
$cencodedSizeExpr :: 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
$cencodedListSizeExpr :: 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
ToCBOR, Context -> MultiSig era -> IO (Maybe ThunkInfo)
Proxy (MultiSig era) -> String
(Context -> MultiSig era -> IO (Maybe ThunkInfo))
-> (Context -> MultiSig era -> IO (Maybe ThunkInfo))
-> (Proxy (MultiSig era) -> String)
-> NoThunks (MultiSig era)
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
$cnoThunks :: forall era.
Typeable era =>
Context -> MultiSig era -> IO (Maybe ThunkInfo)
noThunks :: Context -> MultiSig era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era.
Typeable era =>
Context -> MultiSig era -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> MultiSig era -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall era. Typeable era => Proxy (MultiSig era) -> String
showTypeOf :: Proxy (MultiSig era) -> String
NoThunks, MultiSig era -> Int
MultiSig era -> ByteString
(MultiSig era -> ByteString)
-> (MultiSig era -> Int)
-> (forall i. Proxy i -> MultiSig era -> SafeHash i)
-> SafeToHash (MultiSig era)
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
$coriginalBytes :: forall era. MultiSig era -> ByteString
originalBytes :: MultiSig era -> ByteString
$coriginalBytesSize :: forall era. MultiSig era -> Int
originalBytesSize :: MultiSig era -> Int
$cmakeHashWithExplicitProxys :: forall era i. Proxy i -> MultiSig era -> SafeHash i
makeHashWithExplicitProxys :: forall i. Proxy i -> MultiSig era -> SafeHash i
SafeToHash)

instance Memoized (MultiSig era) where
  type RawType (MultiSig era) = MultiSigRaw era

deriving via
  Mem (MultiSigRaw era)
  instance
    Era era => DecCBOR (Annotator (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 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 = String -> Script ByronEra -> MultiSig ShelleyEra
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 = Script ShelleyEra -> Maybe (NativeScript ShelleyEra)
MultiSig ShelleyEra -> Maybe (MultiSig ShelleyEra)
forall a. a -> Maybe a
Just

  fromNativeScript :: NativeScript ShelleyEra -> Script ShelleyEra
fromNativeScript = NativeScript ShelleyEra -> Script ShelleyEra
MultiSig ShelleyEra -> MultiSig ShelleyEra
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 =
    MemoBytes (MultiSigRaw ShelleyEra) -> MultiSig ShelleyEra
forall era. MemoBytes (MultiSigRaw era) -> MultiSig era
MkMultiSig (MemoBytes (MultiSigRaw ShelleyEra) -> MultiSig ShelleyEra)
-> MemoBytes (MultiSigRaw ShelleyEra) -> MultiSig ShelleyEra
forall a b. (a -> b) -> a -> b
$ forall era (w :: Wrapped) t. Era era => Encode w t -> MemoBytes t
memoBytesEra @ShelleyEra ((KeyHash Witness -> MultiSigRaw ShelleyEra)
-> Word -> Encode Open (KeyHash Witness -> MultiSigRaw ShelleyEra)
forall t. t -> Word -> Encode Open t
Sum KeyHash Witness -> MultiSigRaw ShelleyEra
forall era. KeyHash Witness -> MultiSigRaw era
MultiSigSignature Word
0 Encode Open (KeyHash Witness -> MultiSigRaw ShelleyEra)
-> Encode (Closed Dense) (KeyHash Witness)
-> Encode Open (MultiSigRaw ShelleyEra)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode (Closed r) a -> Encode w t
!> KeyHash Witness -> Encode (Closed Dense) (KeyHash Witness)
forall t. EncCBOR t => t -> Encode (Closed Dense) t
To KeyHash Witness
kh)
  getRequireSignature :: NativeScript ShelleyEra -> Maybe (KeyHash Witness)
getRequireSignature (MkMultiSig (Memo (MultiSigSignature KeyHash Witness
kh) ShortByteString
_)) = KeyHash Witness -> Maybe (KeyHash Witness)
forall a. a -> Maybe a
Just KeyHash Witness
kh
  getRequireSignature NativeScript ShelleyEra
_ = Maybe (KeyHash Witness)
forall a. Maybe a
Nothing

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

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

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

deriving newtype instance NFData (MultiSig era)

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

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

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

pattern RequireAnyOf :: ShelleyEraScript era => StrictSeq (NativeScript era) -> NativeScript era
pattern $mRequireAnyOf :: forall {r} {era}.
ShelleyEraScript era =>
NativeScript era
-> (StrictSeq (NativeScript era) -> r) -> ((# #) -> r) -> r
$bRequireAnyOf :: forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf ms <- (getRequireAnyOf -> Just ms)
  where
    RequireAnyOf StrictSeq (NativeScript era)
ms = StrictSeq (NativeScript era) -> NativeScript era
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 $mRequireMOf :: forall {r} {era}.
ShelleyEraScript era =>
NativeScript era
-> (Int -> StrictSeq (NativeScript era) -> r) -> ((# #) -> r) -> r
$bRequireMOf :: forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf n ms <- (getRequireMOf -> Just (n, ms))
  where
    RequireMOf Int
n StrictSeq (NativeScript era)
ms = Int -> StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
mkRequireMOf Int
n StrictSeq (NativeScript era)
ms

{-# COMPLETE
  RequireSignature
  , RequireAllOf
  , RequireAnyOf
  , RequireMOf ::
    ShelleyEra
  #-}

-- | 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 = Text
-> (Word -> Decoder s (Int, Annotator (MultiSigRaw era)))
-> Decoder s (Annotator (MultiSigRaw era))
forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
"MultiSig" ((Word -> Decoder s (Int, Annotator (MultiSigRaw era)))
 -> Decoder s (Annotator (MultiSigRaw era)))
-> (Word -> Decoder s (Int, Annotator (MultiSigRaw era)))
-> Decoder s (Annotator (MultiSigRaw era))
forall a b. (a -> b) -> a -> b
$
    \case
      Word
0 -> (,) Int
2 (Annotator (MultiSigRaw era) -> (Int, Annotator (MultiSigRaw era)))
-> (Hash ADDRHASH (VerKeyDSIGN DSIGN)
    -> Annotator (MultiSigRaw era))
-> Hash ADDRHASH (VerKeyDSIGN DSIGN)
-> (Int, Annotator (MultiSigRaw era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiSigRaw era -> Annotator (MultiSigRaw era)
forall a. a -> Annotator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MultiSigRaw era -> Annotator (MultiSigRaw era))
-> (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> MultiSigRaw era)
-> Hash ADDRHASH (VerKeyDSIGN DSIGN)
-> Annotator (MultiSigRaw era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash Witness -> MultiSigRaw era
forall era. KeyHash Witness -> MultiSigRaw era
MultiSigSignature (KeyHash Witness -> MultiSigRaw era)
-> (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash Witness)
-> Hash ADDRHASH (VerKeyDSIGN DSIGN)
-> MultiSigRaw era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash Witness
forall (r :: KeyRole).
Hash ADDRHASH (VerKeyDSIGN DSIGN) -> KeyHash r
KeyHash (Hash ADDRHASH (VerKeyDSIGN DSIGN)
 -> (Int, Annotator (MultiSigRaw era)))
-> Decoder s (Hash ADDRHASH (VerKeyDSIGN DSIGN))
-> Decoder s (Int, Annotator (MultiSigRaw era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Hash ADDRHASH (VerKeyDSIGN DSIGN))
forall s. Decoder s (Hash ADDRHASH (VerKeyDSIGN DSIGN))
forall a s. DecCBOR a => Decoder s a
decCBOR
      Word
1 -> do
        multiSigs <- StrictSeq (Annotator (MultiSig era))
-> Annotator (StrictSeq (MultiSig era))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a.
Monad m =>
StrictSeq (m a) -> m (StrictSeq a)
sequence (StrictSeq (Annotator (MultiSig era))
 -> Annotator (StrictSeq (MultiSig era)))
-> Decoder s (StrictSeq (Annotator (MultiSig era)))
-> Decoder s (Annotator (StrictSeq (MultiSig era)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (StrictSeq (Annotator (MultiSig era)))
forall s. Decoder s (StrictSeq (Annotator (MultiSig era)))
forall a s. DecCBOR a => Decoder s a
decCBOR
        pure (2, MultiSigAllOf <$> multiSigs)
      Word
2 -> do
        multiSigs <- StrictSeq (Annotator (MultiSig era))
-> Annotator (StrictSeq (MultiSig era))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a.
Monad m =>
StrictSeq (m a) -> m (StrictSeq a)
sequence (StrictSeq (Annotator (MultiSig era))
 -> Annotator (StrictSeq (MultiSig era)))
-> Decoder s (StrictSeq (Annotator (MultiSig era)))
-> Decoder s (Annotator (StrictSeq (MultiSig era)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (StrictSeq (Annotator (MultiSig era)))
forall s. Decoder s (StrictSeq (Annotator (MultiSig era)))
forall a s. DecCBOR a => Decoder s a
decCBOR
        pure (2, MultiSigAnyOf <$> multiSigs)
      Word
3 -> do
        m <- Decoder s Int
forall s. Decoder s Int
forall a s. DecCBOR a => Decoder s a
decCBOR
        multiSigs <- sequence <$> decCBOR
        pure (3, MultiSigMOf m <$> multiSigs)
      Word
k -> Word -> Decoder s (Int, Annotator (MultiSigRaw era))
forall a (m :: * -> *). (Typeable 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 = MultiSigRaw era -> MultiSigRaw era -> Bool
forall era. MultiSigRaw era -> MultiSigRaw era -> Bool
go (MultiSig era -> RawType (MultiSig era)
forall t. Memoized t => t -> RawType t
getMemoRawType MultiSig era
t1) (MultiSig era -> RawType (MultiSig era)
forall t. Memoized t => t -> RawType t
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) = MultiSig era -> MultiSig era -> Bool
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 (MultiSigSignature KeyHash Witness
kh1) (MultiSigSignature KeyHash Witness
kh2) = KeyHash Witness
kh1 KeyHash Witness -> KeyHash Witness -> Bool
forall a. Eq a => a -> a -> Bool
== KeyHash Witness
kh2
    go (MultiSigAllOf StrictSeq (MultiSig era)
ts1) (MultiSigAllOf StrictSeq (MultiSig era)
ts2) = StrictSeq (MultiSig era) -> StrictSeq (MultiSig era) -> Bool
forall {era}.
StrictSeq (MultiSig era) -> StrictSeq (MultiSig era) -> Bool
seqEq StrictSeq (MultiSig era)
ts1 StrictSeq (MultiSig era)
ts2
    go (MultiSigAnyOf StrictSeq (MultiSig era)
ts1) (MultiSigAnyOf StrictSeq (MultiSig era)
ts2) = StrictSeq (MultiSig era) -> StrictSeq (MultiSig era) -> Bool
forall {era}.
StrictSeq (MultiSig era) -> StrictSeq (MultiSig era) -> Bool
seqEq StrictSeq (MultiSig era)
ts1 StrictSeq (MultiSig era)
ts2
    go (MultiSigMOf Int
n1 StrictSeq (MultiSig era)
ts1) (MultiSigMOf Int
n2 StrictSeq (MultiSig era)
ts2) = Int
n1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n2 Bool -> Bool -> Bool
&& StrictSeq (MultiSig era) -> StrictSeq (MultiSig era) -> 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
    isValidMOf Int
n (NativeScript era
msig StrictSeq.:<| StrictSeq (NativeScript era)
msigs) =
      Int
n Int -> Int -> Bool
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 Int -> Int -> Int
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 -> KeyHash Witness -> Set (KeyHash Witness) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member KeyHash Witness
hk Set (KeyHash Witness)
vhks
      RequireAllOf StrictSeq (NativeScript era)
msigs -> (NativeScript era -> Bool) -> StrictSeq (NativeScript era) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all NativeScript era -> Bool
go StrictSeq (NativeScript era)
msigs
      RequireAnyOf StrictSeq (NativeScript era)
msigs -> (NativeScript era -> Bool) -> StrictSeq (NativeScript era) -> Bool
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
_ -> String -> Bool
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 t era ->
  NativeScript era ->
  Bool
validateMultiSig :: forall era (t :: TxLevel).
(ShelleyEraScript era, EraTx era,
 NativeScript era ~ MultiSig era) =>
Tx t era -> NativeScript era -> Bool
validateMultiSig Tx t era
tx =
  Set (KeyHash Witness) -> NativeScript era -> Bool
forall era.
(ShelleyEraScript era, NativeScript era ~ MultiSig era) =>
Set (KeyHash Witness) -> NativeScript era -> Bool
evalMultiSig (Set (KeyHash Witness) -> NativeScript era -> Bool)
-> Set (KeyHash Witness) -> NativeScript era -> Bool
forall a b. (a -> b) -> a -> b
$ (WitVKey Witness -> KeyHash Witness)
-> Set (WitVKey Witness) -> Set (KeyHash Witness)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map WitVKey Witness -> KeyHash Witness
forall (kr :: KeyRole). WitVKey kr -> KeyHash Witness
witVKeyHash (Tx t era
tx Tx t era
-> Getting
     (Set (WitVKey Witness)) (Tx t era) (Set (WitVKey Witness))
-> Set (WitVKey Witness)
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Set (WitVKey Witness)) (TxWits era))
-> Tx t era -> Const (Set (WitVKey Witness)) (Tx t era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l era) (TxWits era)
witsTxL ((TxWits era -> Const (Set (WitVKey Witness)) (TxWits era))
 -> Tx t era -> Const (Set (WitVKey Witness)) (Tx t era))
-> ((Set (WitVKey Witness)
     -> Const (Set (WitVKey Witness)) (Set (WitVKey Witness)))
    -> TxWits era -> Const (Set (WitVKey Witness)) (TxWits era))
-> Getting
     (Set (WitVKey Witness)) (Tx t era) (Set (WitVKey Witness))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey Witness)
 -> Const (Set (WitVKey Witness)) (Set (WitVKey Witness)))
-> TxWits era -> Const (Set (WitVKey Witness)) (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey Witness))
Lens' (TxWits era) (Set (WitVKey Witness))
addrTxWitsL)
{-# INLINE validateMultiSig #-}