{-# 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 (
  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 (..),
  MemoBytes,
  Memoized (..),
  decodeMemoized,
  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

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

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

instance Era era => DecCBOR (MultiSig era) where
  decCBOR :: forall s. Decoder s (MultiSig era)
decCBOR = MemoBytes (MultiSigRaw era) -> MultiSig era
forall era. MemoBytes (MultiSigRaw era) -> MultiSig era
MkMultiSig (MemoBytes (MultiSigRaw era) -> MultiSig era)
-> Decoder s (MemoBytes (MultiSigRaw era))
-> Decoder s (MultiSig era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (MultiSigRaw era)
-> Decoder s (MemoBytes (MultiSigRaw era))
forall s t. Decoder s t -> Decoder s (MemoBytes t)
decodeMemoized Decoder s (MultiSigRaw era)
forall s. Decoder s (MultiSigRaw era)
forall a s. DecCBOR a => Decoder s a
decCBOR

instance Era era => DecCBOR (MultiSigRaw era) where
  decCBOR :: forall s. Decoder s (MultiSigRaw era)
decCBOR = Text
-> (Word -> Decoder s (Int, MultiSigRaw era))
-> Decoder s (MultiSigRaw era)
forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
"MultiSig" ((Word -> Decoder s (Int, MultiSigRaw era))
 -> Decoder s (MultiSigRaw era))
-> (Word -> Decoder s (Int, MultiSigRaw era))
-> Decoder s (MultiSigRaw era)
forall a b. (a -> b) -> a -> b
$ do
    \case
      Word
0 -> (,) Int
2 (MultiSigRaw era -> (Int, MultiSigRaw era))
-> (Hash ADDRHASH (VerKeyDSIGN DSIGN) -> MultiSigRaw era)
-> Hash ADDRHASH (VerKeyDSIGN DSIGN)
-> (Int, 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, MultiSigRaw era))
-> Decoder s (Hash ADDRHASH (VerKeyDSIGN DSIGN))
-> Decoder s (Int, 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 -> (,) Int
2 (MultiSigRaw era -> (Int, MultiSigRaw era))
-> (StrictSeq (MultiSig era) -> MultiSigRaw era)
-> StrictSeq (MultiSig era)
-> (Int, MultiSigRaw era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (MultiSig era) -> MultiSigRaw era
forall era. StrictSeq (MultiSig era) -> MultiSigRaw era
MultiSigAllOf (StrictSeq (MultiSig era) -> (Int, MultiSigRaw era))
-> Decoder s (StrictSeq (MultiSig era))
-> Decoder s (Int, MultiSigRaw era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (StrictSeq (MultiSig era))
forall s. Decoder s (StrictSeq (MultiSig era))
forall a s. DecCBOR a => Decoder s a
decCBOR
      Word
2 -> (,) Int
2 (MultiSigRaw era -> (Int, MultiSigRaw era))
-> (StrictSeq (MultiSig era) -> MultiSigRaw era)
-> StrictSeq (MultiSig era)
-> (Int, MultiSigRaw era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (MultiSig era) -> MultiSigRaw era
forall era. StrictSeq (MultiSig era) -> MultiSigRaw era
MultiSigAnyOf (StrictSeq (MultiSig era) -> (Int, MultiSigRaw era))
-> Decoder s (StrictSeq (MultiSig era))
-> Decoder s (Int, MultiSigRaw era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (StrictSeq (MultiSig era))
forall s. Decoder s (StrictSeq (MultiSig era))
forall a s. DecCBOR a => Decoder s a
decCBOR
      Word
3 -> (,) Int
3 (MultiSigRaw era -> (Int, MultiSigRaw era))
-> Decoder s (MultiSigRaw era) -> Decoder s (Int, MultiSigRaw era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> StrictSeq (MultiSig era) -> MultiSigRaw era
forall era. Int -> StrictSeq (MultiSig era) -> MultiSigRaw era
MultiSigMOf (Int -> StrictSeq (MultiSig era) -> MultiSigRaw era)
-> Decoder s Int
-> Decoder s (StrictSeq (MultiSig era) -> MultiSigRaw era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Int
forall s. Decoder s Int
forall a s. DecCBOR a => Decoder s a
decCBOR Decoder s (StrictSeq (MultiSig era) -> MultiSigRaw era)
-> Decoder s (StrictSeq (MultiSig era))
-> Decoder s (MultiSigRaw era)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (StrictSeq (MultiSig era))
forall s. Decoder s (StrictSeq (MultiSig era))
forall a s. DecCBOR a => Decoder s a
decCBOR)
      Word
k -> Word -> Decoder s (Int, 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 era ->
  NativeScript era ->
  Bool
validateMultiSig :: forall era.
(ShelleyEraScript era, EraTx era,
 NativeScript era ~ MultiSig era) =>
Tx era -> NativeScript era -> Bool
validateMultiSig Tx 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 era
tx Tx era
-> Getting
     (Set (WitVKey 'Witness)) (Tx 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 era -> Const (Set (WitVKey 'Witness)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Const (Set (WitVKey 'Witness)) (TxWits era))
 -> Tx era -> Const (Set (WitVKey 'Witness)) (Tx era))
-> ((Set (WitVKey 'Witness)
     -> Const (Set (WitVKey 'Witness)) (Set (WitVKey 'Witness)))
    -> TxWits era -> Const (Set (WitVKey 'Witness)) (TxWits era))
-> Getting
     (Set (WitVKey 'Witness)) (Tx 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 #-}