{-# LANGUAGE TemplateHaskell #-}

{- |
Module     : Plutarch.Extra.MultiSig
Maintainer : [email protected]
Description: A basic N of M multisignature validation function.

A basic N of M multisignature validation function.
-}
module Plutarch.Extra.MultiSig (
  validatedByMultisig,
  pvalidatedByMultisig,
  PMultiSig (..),
  MultiSig,
  mkMultiSig,
  PMultiSigContext,
  pmultiSigContext,
) where

import GHC.Records (HasField)
import Optics.Getter (A_Getter, to)
import Optics.Label (LabelOptic (labelOptic))
import Optics.Traversal (A_Traversal, traversalVL)
import Plutarch.Api.V2 (PPubKeyHash)
import Plutarch.DataRepr (
  DerivePConstantViaData (DerivePConstantViaData),
  PDataFields,
 )
import Plutarch.Extra.Field (pletAllC)
import Plutarch.Extra.Function (pflip)
import Plutarch.Extra.TermCont (pmatchC)
import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl)
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
import PlutusTx qualified (makeLift, unstableMakeIsData)

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

     @since 3.8.0
-}
data MultiSig = MultiSig [PubKeyHash] Integer
  deriving stock
    ( -- | @since 0.1.0
      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
Generic
    , -- | @since 0.1.0
      MultiSig -> MultiSig -> Bool
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
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
    )

{- | Allows traversing over the list of 'PubKeyHash'es that must be present in
 the list of signatories.

 @since 3.8.0
-}
instance
  (k ~ A_Traversal, a ~ PubKeyHash, b ~ PubKeyHash) =>
  LabelOptic "keys" k MultiSig MultiSig a b
  where
  labelOptic :: Optic k NoIx MultiSig MultiSig a b
labelOptic = forall s t a b. TraversalVL s t a b -> Traversal s t a b
traversalVL forall a b. (a -> b) -> a -> b
$
    \a -> f b
f (MultiSig [PubKeyHash]
pkhs Integer
minSigs) -> [PubKeyHash] -> Integer -> MultiSig
MultiSig forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f [PubKeyHash]
pkhs forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Integer
minSigs

{- | Allows access to (but not changing) the minimum number of signatories that
 must be present. Changing this field independently is forbidden, as it could
 construct an invalid result.

 @since 3.8.0
-}
instance
  (k ~ A_Getter, a ~ Integer, b ~ Integer) =>
  LabelOptic "minSigs" k MultiSig MultiSig a b
  where
  labelOptic :: Optic k NoIx MultiSig MultiSig a b
labelOptic = forall s a. (s -> a) -> Getter s a
to forall a b. (a -> b) -> a -> b
$ \(MultiSig [PubKeyHash]
_ Integer
minSigs) -> Integer
minSigs

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

{- | Given a list of keys, and a minimum number of signatories, returns
 'Nothing' if given too few keys, or 'Just' a 'MultiSig' otherwise.

 @since 3.8.0
-}
mkMultiSig :: [PubKeyHash] -> Integer -> Maybe MultiSig
mkMultiSig :: [PubKeyHash] -> Integer -> Maybe MultiSig
mkMultiSig [PubKeyHash]
pkhs Integer
minSigs
  | forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [PubKeyHash]
pkhs forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
minSigs = forall a. Maybe a
Nothing
  | Bool
otherwise = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PubKeyHash] -> Integer -> MultiSig
MultiSig [PubKeyHash]
pkhs forall a b. (a -> b) -> a -> b
$ Integer
minSigs

{- | Plutarch-level MultiSig

     @since 0.1.0
-}
newtype PMultiSig (s :: S) = PMultiSig
  { forall (s :: S).
PMultiSig s
-> Term
     s
     (PDataRecord
        '[ "keys" ':= PBuiltinList (PAsData PPubKeyHash),
           "minSigs" ':= PInteger])
getMultiSig ::
      Term
        s
        ( PDataRecord
            '[ "keys" ':= PBuiltinList (PAsData PPubKeyHash)
             , "minSigs" ':= PInteger
             ]
        )
  }
  deriving stock
    ( -- | @since 0.1.0
      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
Generic
    )
  deriving anyclass
    ( -- | @since 0.1.0
      forall (s :: S). PMultiSig s -> Term s (PInner PMultiSig)
forall (s :: S) (b :: PType).
Term s (PInner PMultiSig) -> (PMultiSig s -> Term s b) -> Term s b
forall (a :: PType).
(forall (s :: S). a s -> Term s (PInner a))
-> (forall (s :: S) (b :: PType).
    Term s (PInner a) -> (a s -> Term s b) -> Term s b)
-> PlutusType a
pmatch' :: forall (s :: S) (b :: PType).
Term s (PInner PMultiSig) -> (PMultiSig s -> Term s b) -> Term s b
$cpmatch' :: forall (s :: S) (b :: PType).
Term s (PInner PMultiSig) -> (PMultiSig s -> Term s b) -> Term s b
pcon' :: forall (s :: S). PMultiSig s -> Term s (PInner PMultiSig)
$cpcon' :: forall (s :: S). PMultiSig s -> Term s (PInner PMultiSig)
PlutusType
    , -- | @since 0.1.0
      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))
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
    )

-- | @since 1.4.0
instance DerivePlutusType PMultiSig where
  type DPTStrat _ = PlutusTypeData

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

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

-- | @since 3.2.0
instance PTryFrom PData PMultiSig

{- | Context required in order to check 'MultiSig'.

     Should be constructed with 'pmultiSigContext'.

     @since 3.8.0
-}
newtype PMultiSigContext (s :: S)
  = PMultiSigContext
      (Term s (PBuiltinList (PAsData PPubKeyHash)))
  deriving stock
    ( -- | @since 3.2.0
      forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (s :: S) x. Rep (PMultiSigContext s) x -> PMultiSigContext s
forall (s :: S) x. PMultiSigContext s -> Rep (PMultiSigContext s) x
$cto :: forall (s :: S) x. Rep (PMultiSigContext s) x -> PMultiSigContext s
$cfrom :: forall (s :: S) x. PMultiSigContext s -> Rep (PMultiSigContext s) x
Generic
    )
  deriving anyclass
    ( -- | @since 3.2.0
      forall (s :: S).
PMultiSigContext s -> Term s (PInner PMultiSigContext)
forall (s :: S) (b :: PType).
Term s (PInner PMultiSigContext)
-> (PMultiSigContext s -> Term s b) -> Term s b
forall (a :: PType).
(forall (s :: S). a s -> Term s (PInner a))
-> (forall (s :: S) (b :: PType).
    Term s (PInner a) -> (a s -> Term s b) -> Term s b)
-> PlutusType a
pmatch' :: forall (s :: S) (b :: PType).
Term s (PInner PMultiSigContext)
-> (PMultiSigContext s -> Term s b) -> Term s b
$cpmatch' :: forall (s :: S) (b :: PType).
Term s (PInner PMultiSigContext)
-> (PMultiSigContext s -> Term s b) -> Term s b
pcon' :: forall (s :: S).
PMultiSigContext s -> Term s (PInner PMultiSigContext)
$cpcon' :: forall (s :: S).
PMultiSigContext s -> Term s (PInner PMultiSigContext)
PlutusType
    , -- | @since 3.2.0
      forall (s :: S).
Term s PMultiSigContext -> Term s PMultiSigContext -> Term s PBool
forall (t :: PType).
(forall (s :: S). Term s t -> Term s t -> Term s PBool) -> PEq t
#== :: forall (s :: S).
Term s PMultiSigContext -> Term s PMultiSigContext -> Term s PBool
$c#== :: forall (s :: S).
Term s PMultiSigContext -> Term s PMultiSigContext -> Term s PBool
PEq
    )

-- | @since 3.2.0
instance DerivePlutusType PMultiSigContext where
  type DPTStrat _ = PlutusTypeNewtype

-- | @since 3.8.0
instance HasField "signatories" (PMultiSigContext s) (Term s (PBuiltinList (PAsData PPubKeyHash))) where
  getField :: PMultiSigContext s -> Term s (PBuiltinList (PAsData PPubKeyHash))
getField (PMultiSigContext Term s (PBuiltinList (PAsData PPubKeyHash))
t) = Term s (PBuiltinList (PAsData PPubKeyHash))
t

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

{- | Construct 'PMultiSigContext' providing the @signatories@ field,
     which typically comes from 'PTxInfo'.

     @since 3.2.0
-}
pmultiSigContext ::
  forall r (s :: S).
  ( HasField "signatories" r (Term s (PBuiltinList (PAsData PPubKeyHash)))
  ) =>
  r ->
  Term s PMultiSigContext
pmultiSigContext :: forall r (s :: S).
HasField
  "signatories" r (Term s (PBuiltinList (PAsData PPubKeyHash))) =>
r -> Term s PMultiSigContext
pmultiSigContext = forall (a :: PType) (s :: S). PlutusType a => a s -> Term s a
pcon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: S).
Term s (PBuiltinList (PAsData PPubKeyHash)) -> PMultiSigContext s
PMultiSigContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"signatories"

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

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

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

     @since 3.2.0
-}
pvalidatedByMultisig :: forall (s :: S). Term s (PMultiSig :--> PMultiSigContext :--> PBool)
pvalidatedByMultisig :: forall (s :: S).
Term s (PMultiSig :--> (PMultiSigContext :--> PBool))
pvalidatedByMultisig =
  forall (a :: PType) (s :: S).
HasCallStack =>
ClosedTerm a -> Term s a
phoistAcyclic forall a b. (a -> b) -> a -> b
$
    forall a (b :: PType) (s :: S) (c :: PType).
(PLamN a b s, HasCallStack) =>
(Term s c -> a) -> Term s (c :--> b)
plam forall a b. (a -> b) -> a -> b
$ \Term s PMultiSig
multi Term s PMultiSigContext
ctx -> forall (a :: PType) (s :: S). TermCont s (Term s a) -> Term s a
unTermCont forall a b. (a -> b) -> a -> b
$ do
      HRec
  '[ '("keys",
       Term s (PAsData (PBuiltinList (PAsData PPubKeyHash)))),
     '("minSigs", Term s (PAsData PInteger))]
multiF <- forall (a :: PType) (s :: S) (b :: PType) (ps :: [PLabeledType])
       (bs :: [ToBind]).
(PDataFields a, ps ~ PFields a, bs ~ Bindings ps (BindAll ps),
 BindFields ps bs) =>
Term s a -> TermCont s (HRec (BoundTerms ps bs s))
pletAllC Term s PMultiSig
multi
      PMultiSigContext Term s (PBuiltinList (PAsData PPubKeyHash))
sigs <- forall {r :: PType} (a :: PType) (s :: S).
PlutusType a =>
Term s a -> TermCont s (a s)
pmatchC Term s PMultiSigContext
ctx

      forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"minSigs" HRec
  '[ '("keys",
       Term s (PAsData (PBuiltinList (PAsData PPubKeyHash)))),
     '("minSigs", Term s (PAsData PInteger))]
multiF
          #<= ( plength #$ pfilter
                  # (pflip # pelem # sigs)
                  # getField @"keys" multiF
              )