{-# LANGUAGE TemplateHaskell #-}

{- |
Module     : Agora.MultiSig
Maintainer : riley_kilgore@outlook.com
Description: A basic N of M multisignature validation function.

A basic N of M multisignature validation function.
-}
module Agora.MultiSig (
  validatedByMultisig,
  pvalidatedByMultisig,
  PMultiSig (..),
  MultiSig (..),
) where

import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (
  PPubKeyHash,
  PTxInfo (..),
 )
import Plutarch.DataRepr (
  DerivePConstantViaData (DerivePConstantViaData),
  PDataFields,
  PIsDataReprInstances (PIsDataReprInstances),
 )
import Plutarch.Lift (
  PConstantDecl,
  PLifted,
  PUnsafeLiftDecl,
 )
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
import PlutusTx qualified
import Prelude

--------------------------------------------------------------------------------

{- | A MultiSig represents a proof that a particular set of signatures
     are present on a transaction.

     @since 0.1.0
-}
data MultiSig = MultiSig
  { MultiSig -> [PubKeyHash]
keys :: [PubKeyHash]
  -- ^ List of PubKeyHashes that must be present in the list of signatories.
  , MultiSig -> Integer
minSigs :: Integer
  }
  deriving stock
    ( -- | @since 0.1.0
      (forall x. MultiSig -> Rep MultiSig x)
-> (forall x. Rep MultiSig x -> MultiSig) -> Generic MultiSig
forall x. Rep MultiSig x -> MultiSig
forall x. MultiSig -> Rep MultiSig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MultiSig x -> MultiSig
$cfrom :: forall x. MultiSig -> Rep MultiSig x
GHC.Generic
    , -- | @since 0.1.0
      MultiSig -> MultiSig -> Bool
(MultiSig -> MultiSig -> Bool)
-> (MultiSig -> MultiSig -> Bool) -> Eq MultiSig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MultiSig -> MultiSig -> Bool
$c/= :: MultiSig -> MultiSig -> Bool
== :: MultiSig -> MultiSig -> Bool
$c== :: MultiSig -> MultiSig -> Bool
Eq
    , -- | @since 0.1.0
      Int -> MultiSig -> ShowS
[MultiSig] -> ShowS
MultiSig -> String
(Int -> MultiSig -> ShowS)
-> (MultiSig -> String) -> ([MultiSig] -> ShowS) -> Show MultiSig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MultiSig] -> ShowS
$cshowList :: [MultiSig] -> ShowS
show :: MultiSig -> String
$cshow :: MultiSig -> String
showsPrec :: Int -> MultiSig -> ShowS
$cshowsPrec :: Int -> MultiSig -> ShowS
Show
    )
  deriving anyclass
    ( -- | @since 0.1.0
      All @[Type] (SListI @Type) (Code MultiSig)
All @[Type] (SListI @Type) (Code MultiSig)
-> (MultiSig -> Rep MultiSig)
-> (Rep MultiSig -> MultiSig)
-> Generic MultiSig
Rep MultiSig -> MultiSig
MultiSig -> Rep MultiSig
forall a.
All @[Type] (SListI @Type) (Code a)
-> (a -> Rep a) -> (Rep a -> a) -> Generic a
to :: Rep MultiSig -> MultiSig
$cto :: Rep MultiSig -> MultiSig
from :: MultiSig -> Rep MultiSig
$cfrom :: MultiSig -> Rep MultiSig
Generic
    )

PlutusTx.makeLift ''MultiSig
PlutusTx.unstableMakeIsData ''MultiSig

{- | Plutarch-level MultiSig

     @since 0.1.0
-}
newtype PMultiSig (s :: S) = PMultiSig
  { forall (s :: S).
PMultiSig s
-> Term
     s
     (PDataRecord
        ((':)
           @PLabeledType
           ("keys" ':= PBuiltinList (PAsData PPubKeyHash))
           ((':)
              @PLabeledType ("minSigs" ':= PInteger @S) ('[] @PLabeledType))))
getMultiSig ::
      Term
        s
        ( PDataRecord
            '[ "keys" ':= PBuiltinList (PAsData PPubKeyHash)
             , "minSigs" ':= PInteger
             ]
        )
  }
  deriving stock
    ( -- | @since 0.1.0
      (forall x. PMultiSig s -> Rep (PMultiSig s) x)
-> (forall x. Rep (PMultiSig s) x -> PMultiSig s)
-> Generic (PMultiSig s)
forall x. Rep (PMultiSig s) x -> PMultiSig s
forall x. PMultiSig s -> Rep (PMultiSig s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (s :: S) x. Rep (PMultiSig s) x -> PMultiSig s
forall (s :: S) x. PMultiSig s -> Rep (PMultiSig s) x
$cto :: forall (s :: S) x. Rep (PMultiSig s) x -> PMultiSig s
$cfrom :: forall (s :: S) x. PMultiSig s -> Rep (PMultiSig s) x
GHC.Generic
    )
  deriving anyclass
    ( -- | @since 0.1.0
      All @[Type] (SListI @Type) (Code (PMultiSig s))
All @[Type] (SListI @Type) (Code (PMultiSig s))
-> (PMultiSig s -> Rep (PMultiSig s))
-> (Rep (PMultiSig s) -> PMultiSig s)
-> Generic (PMultiSig s)
Rep (PMultiSig s) -> PMultiSig s
PMultiSig s -> Rep (PMultiSig s)
forall a.
All @[Type] (SListI @Type) (Code a)
-> (a -> Rep a) -> (Rep a -> a) -> Generic a
forall {s :: S}. All @[Type] (SListI @Type) (Code (PMultiSig s))
forall (s :: S). Rep (PMultiSig s) -> PMultiSig s
forall (s :: S). PMultiSig s -> Rep (PMultiSig s)
to :: Rep (PMultiSig s) -> PMultiSig s
$cto :: forall (s :: S). Rep (PMultiSig s) -> PMultiSig s
from :: PMultiSig s -> Rep (PMultiSig s)
$cfrom :: forall (s :: S). PMultiSig s -> Rep (PMultiSig s)
Generic
    )
  deriving anyclass
    ( -- | @since 0.1.0
      PIsData PMultiSig
PlutusType PMultiSig
PlutusType PMultiSig
-> PIsData PMultiSig
-> (forall (s :: S).
    PMultiSig s -> Term s (PDataSum (PIsDataReprRepr PMultiSig)))
-> (forall (s :: S) (b :: PType).
    Term s (PDataSum (PIsDataReprRepr PMultiSig))
    -> (PMultiSig s -> Term s b) -> Term s b)
-> PIsDataRepr PMultiSig
forall (s :: S).
PMultiSig s -> Term s (PDataSum (PIsDataReprRepr PMultiSig))
forall (s :: S) (b :: PType).
Term s (PDataSum (PIsDataReprRepr PMultiSig))
-> (PMultiSig s -> Term s b) -> Term s b
forall (a :: PType).
PlutusType a
-> PIsData a
-> (forall (s :: S). a s -> Term s (PDataSum (PIsDataReprRepr a)))
-> (forall (s :: S) (b :: PType).
    Term s (PDataSum (PIsDataReprRepr a))
    -> (a s -> Term s b) -> Term s b)
-> PIsDataRepr a
pmatchRepr :: forall (s :: S) (b :: PType).
Term s (PDataSum (PIsDataReprRepr PMultiSig))
-> (PMultiSig s -> Term s b) -> Term s b
$cpmatchRepr :: forall (s :: S) (b :: PType).
Term s (PDataSum (PIsDataReprRepr PMultiSig))
-> (PMultiSig s -> Term s b) -> Term s b
pconRepr :: forall (s :: S).
PMultiSig s -> Term s (PDataSum (PIsDataReprRepr PMultiSig))
$cpconRepr :: forall (s :: S).
PMultiSig s -> Term s (PDataSum (PIsDataReprRepr PMultiSig))
PIsDataRepr
    )
  deriving
    ( -- | @since 0.1.0
      PCon PMultiSig
PMatch PMultiSig
PCon PMultiSig
-> PMatch PMultiSig
-> (forall (s :: S) (b :: PType).
    PMultiSig s -> Term s (PInner PMultiSig b))
-> (forall (s :: S) (b :: PType).
    Term s (PInner PMultiSig b)
    -> (PMultiSig s -> Term s b) -> Term s b)
-> PlutusType PMultiSig
forall (s :: S) (b :: PType).
Term s (PInner PMultiSig b)
-> (PMultiSig s -> Term s b) -> Term s b
forall (s :: S) (b :: PType).
PMultiSig s -> Term s (PInner PMultiSig b)
forall (a :: PType).
PCon a
-> PMatch a
-> (forall (s :: S) (b :: PType). a s -> Term s (PInner a b))
-> (forall (s :: S) (b :: PType).
    Term s (PInner a b) -> (a s -> Term s b) -> Term s b)
-> PlutusType a
pmatch' :: forall (s :: S) (b :: PType).
Term s (PInner PMultiSig b)
-> (PMultiSig s -> Term s b) -> Term s b
$cpmatch' :: forall (s :: S) (b :: PType).
Term s (PInner PMultiSig b)
-> (PMultiSig s -> Term s b) -> Term s b
pcon' :: forall (s :: S) (b :: PType).
PMultiSig s -> Term s (PInner PMultiSig b)
$cpcon' :: forall (s :: S) (b :: PType).
PMultiSig s -> Term s (PInner PMultiSig b)
PlutusType
    , -- | @since 0.1.0
      (forall (s :: S). Term s (PAsData PMultiSig) -> Term s PMultiSig)
-> (forall (s :: S). Term s PMultiSig -> Term s PData)
-> PIsData PMultiSig
forall (s :: S). Term s (PAsData PMultiSig) -> Term s PMultiSig
forall (s :: S). Term s PMultiSig -> Term s PData
forall (a :: PType).
(forall (s :: S). Term s (PAsData a) -> Term s a)
-> (forall (s :: S). Term s a -> Term s PData) -> PIsData a
pdataImpl :: forall (s :: S). Term s PMultiSig -> Term s PData
$cpdataImpl :: forall (s :: S). Term s PMultiSig -> Term s PData
pfromDataImpl :: forall (s :: S). Term s (PAsData PMultiSig) -> Term s PMultiSig
$cpfromDataImpl :: forall (s :: S). Term s (PAsData PMultiSig) -> Term s PMultiSig
PIsData
    , -- | @since 0.1.0
      (forall (s :: S).
 Term s PMultiSig -> Term s (PDataRecord (PFields PMultiSig)))
-> PDataFields PMultiSig
forall (s :: S).
Term s PMultiSig -> Term s (PDataRecord (PFields PMultiSig))
forall (a :: PType).
(forall (s :: S). Term s a -> Term s (PDataRecord (PFields a)))
-> PDataFields a
ptoFields :: forall (s :: S).
Term s PMultiSig -> Term s (PDataRecord (PFields PMultiSig))
$cptoFields :: forall (s :: S).
Term s PMultiSig -> Term s (PDataRecord (PFields PMultiSig))
PDataFields
    )
    via (PIsDataReprInstances PMultiSig)

-- | @since 0.1.0
instance PUnsafeLiftDecl PMultiSig where type PLifted PMultiSig = MultiSig

-- | @since 0.1.0
deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstantDecl MultiSig)

--------------------------------------------------------------------------------

{- | Check if a Haskell-level MultiSig signs this transaction.

     @since 0.1.0
-}
validatedByMultisig :: MultiSig -> Term s (PTxInfo :--> PBool)
validatedByMultisig :: forall (s :: S). MultiSig -> Term s (PTxInfo :--> PBool)
validatedByMultisig MultiSig
params =
  ClosedTerm (PTxInfo :--> PBool) -> Term s (PTxInfo :--> PBool)
forall (a :: PType) (s :: S).
HasCallStack =>
ClosedTerm a -> Term s a
phoistAcyclic (ClosedTerm (PTxInfo :--> PBool) -> Term s (PTxInfo :--> PBool))
-> ClosedTerm (PTxInfo :--> PBool) -> Term s (PTxInfo :--> PBool)
forall a b. (a -> b) -> a -> b
$
    Term s (PMultiSig :--> (PTxInfo :--> PBool))
forall (s :: S). Term s (PMultiSig :--> (PTxInfo :--> PBool))
pvalidatedByMultisig Term s (PMultiSig :--> (PTxInfo :--> PBool))
-> Term s PMultiSig -> Term s (PTxInfo :--> PBool)
forall (s :: S) (a :: PType) (b :: PType).
Term s (a :--> b) -> Term s a -> Term s b
# PLifted PMultiSig -> Term s PMultiSig
forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant PLifted PMultiSig
MultiSig
params

{- | Check if a Plutarch-level MultiSig signs this transaction.

     @since 0.1.0
-}
pvalidatedByMultisig :: Term s (PMultiSig :--> PTxInfo :--> PBool)
pvalidatedByMultisig :: forall (s :: S). Term s (PMultiSig :--> (PTxInfo :--> PBool))
pvalidatedByMultisig =
  (forall (s :: S). Term s (PMultiSig :--> (PTxInfo :--> PBool)))
-> Term s (PMultiSig :--> (PTxInfo :--> PBool))
forall (a :: PType) (s :: S).
HasCallStack =>
ClosedTerm a -> Term s a
phoistAcyclic ((forall (s :: S). Term s (PMultiSig :--> (PTxInfo :--> PBool)))
 -> Term s (PMultiSig :--> (PTxInfo :--> PBool)))
-> (forall (s :: S). Term s (PMultiSig :--> (PTxInfo :--> PBool)))
-> Term s (PMultiSig :--> (PTxInfo :--> PBool))
forall a b. (a -> b) -> a -> b
$
    (Term s PMultiSig -> Term s PTxInfo -> Term s PBool)
-> Term s (PMultiSig :--> (PTxInfo :--> PBool))
forall a (b :: PType) (s :: S) (c :: PType).
PLamN a b s =>
(Term s c -> a) -> Term s (c :--> b)
plam ((Term s PMultiSig -> Term s PTxInfo -> Term s PBool)
 -> Term s (PMultiSig :--> (PTxInfo :--> PBool)))
-> (Term s PMultiSig -> Term s PTxInfo -> Term s PBool)
-> Term s (PMultiSig :--> (PTxInfo :--> PBool))
forall a b. (a -> b) -> a -> b
$ \Term s PMultiSig
multi' Term s PTxInfo
txInfo -> TermCont @PBool s (Term s PBool) -> Term s PBool
forall (a :: PType) (s :: S). TermCont @a s (Term s a) -> Term s a
unTermCont (TermCont @PBool s (Term s PBool) -> Term s PBool)
-> TermCont @PBool s (Term s PBool) -> Term s PBool
forall a b. (a -> b) -> a -> b
$ do
      HRec
  ((':)
     @(Symbol, Type)
     '("keys", Term s (PAsData (PBuiltinList (PAsData PPubKeyHash))))
     ((':)
        @(Symbol, Type)
        '("minSigs", Term s (PAsData (PInteger @S)))
        ('[] @(Symbol, Type))))
multi <- ((HRec
    ((':)
       @(Symbol, Type)
       '("keys", Term s (PAsData (PBuiltinList (PAsData PPubKeyHash))))
       ((':)
          @(Symbol, Type)
          '("minSigs", Term s (PAsData (PInteger @S)))
          ('[] @(Symbol, Type))))
  -> Term s PBool)
 -> Term s PBool)
-> TermCont
     @PBool
     s
     (HRec
        ((':)
           @(Symbol, Type)
           '("keys", Term s (PAsData (PBuiltinList (PAsData PPubKeyHash))))
           ((':)
              @(Symbol, Type)
              '("minSigs", Term s (PAsData (PInteger @S)))
              ('[] @(Symbol, Type)))))
forall a (s :: S) (r :: PType).
((a -> Term s r) -> Term s r) -> TermCont @r s a
tcont (((HRec
     ((':)
        @(Symbol, Type)
        '("keys", Term s (PAsData (PBuiltinList (PAsData PPubKeyHash))))
        ((':)
           @(Symbol, Type)
           '("minSigs", Term s (PAsData (PInteger @S)))
           ('[] @(Symbol, Type))))
   -> Term s PBool)
  -> Term s PBool)
 -> TermCont
      @PBool
      s
      (HRec
         ((':)
            @(Symbol, Type)
            '("keys", Term s (PAsData (PBuiltinList (PAsData PPubKeyHash))))
            ((':)
               @(Symbol, Type)
               '("minSigs", Term s (PAsData (PInteger @S)))
               ('[] @(Symbol, Type))))))
-> ((HRec
       ((':)
          @(Symbol, Type)
          '("keys", Term s (PAsData (PBuiltinList (PAsData PPubKeyHash))))
          ((':)
             @(Symbol, Type)
             '("minSigs", Term s (PAsData (PInteger @S)))
             ('[] @(Symbol, Type))))
     -> Term s PBool)
    -> Term s PBool)
-> TermCont
     @PBool
     s
     (HRec
        ((':)
           @(Symbol, Type)
           '("keys", Term s (PAsData (PBuiltinList (PAsData PPubKeyHash))))
           ((':)
              @(Symbol, Type)
              '("minSigs", Term s (PAsData (PInteger @S)))
              ('[] @(Symbol, Type)))))
forall a b. (a -> b) -> a -> b
$ forall (fs :: [Symbol]) (a :: PType) (s :: S) (b :: PType)
       (ps :: [PLabeledType]) (bs :: [ToBind]).
(PDataFields a,
 (ps :: [PLabeledType]) ~ (PFields a :: [PLabeledType]),
 (bs :: [ToBind]) ~ (Bindings ps fs :: [ToBind]),
 BindFields ps bs) =>
Term s a -> (HRecOf a fs s -> Term s b) -> Term s b
pletFields @'["keys", "minSigs"] Term s PMultiSig
multi'
      let signatories :: Term s (PAsData (PBuiltinList (PAsData PPubKeyHash)))
signatories = forall (name :: Symbol) (p :: PType) (s :: S) (a :: PType)
       (as :: [PLabeledType]) (n :: Nat) (b :: PType).
(PDataFields p,
 (as :: [PLabeledType]) ~ (PFields p :: [PLabeledType]),
 (n :: Nat) ~ (PLabelIndex name as :: Nat), KnownNat n,
 (a :: PType) ~ (PUnLabel (IndexList @PLabeledType n as) :: PType),
 PFromDataable a b) =>
Term s (p :--> b)
pfield @"signatories" Term s (PTxInfo :--> PAsData (PBuiltinList (PAsData PPubKeyHash)))
-> Term s PTxInfo
-> Term s (PAsData (PBuiltinList (PAsData PPubKeyHash)))
forall (s :: S) (a :: PType) (b :: PType).
Term s (a :--> b) -> Term s a -> Term s b
# Term s PTxInfo
txInfo
      Term s PBool -> TermCont @PBool s (Term s PBool)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term s PBool -> TermCont @PBool s (Term s PBool))
-> Term s PBool -> TermCont @PBool s (Term s PBool)
forall a b. (a -> b) -> a -> b
$
        Term s (PAsData (PInteger @S)) -> Term s (PInteger @S)
forall (a :: PType) (s :: S).
PIsData a =>
Term s (PAsData a) -> Term s a
pfromData HRec
  ((':)
     @(Symbol, Type)
     '("keys", Term s (PAsData (PBuiltinList (PAsData PPubKeyHash))))
     ((':)
        @(Symbol, Type)
        '("minSigs", Term s (PAsData (PInteger @S)))
        ('[] @(Symbol, Type))))
multi.minSigs
          #<= ( plength #$ pfilter
                  # plam
                    ( \a ->
                        pelem # a # pfromData signatories
                    )
                  # multi.keys
              )