{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
-- | A "pay-to-pubkey" transaction output implemented as a Plutus
--   contract. This is useful if you need something that behaves like
--   a pay-to-pubkey output, but is not (easily) identified by wallets
--   as one.
module Plutus.Contracts.PubKey(pubKeyContract, typedValidator, PubKeyError(..), AsPubKeyError(..)) where

import Control.Lens
import Control.Monad (void)
import Control.Monad.Error.Lens
import Data.Aeson (FromJSON, ToJSON)
import Data.Map qualified as Map
import GHC.Generics (Generic)

import Cardano.Node.Emulator.Internal.Node (pNetworkId)
import Ledger hiding (Value, initialise, to)
import Ledger.Tx.CardanoAPI (fromCardanoTxIn)
import Ledger.Tx.Constraints qualified as Constraints
import Ledger.Typed.Scripts qualified as Scripts
import Plutus.ChainIndex.Types (Tip (Tip, TipAtGenesis))
import Plutus.Contract as Contract
import Plutus.Script.Utils.V2.Typed.Scripts qualified as V2
import Plutus.V2.Ledger.Api (Value)
import Plutus.V2.Ledger.Contexts qualified as V2
import PlutusTx qualified

mkValidator :: PaymentPubKeyHash -> () -> () -> V2.ScriptContext -> Bool
mkValidator :: PaymentPubKeyHash -> () -> () -> ScriptContext -> Bool
mkValidator PaymentPubKeyHash
pk' ()
_ ()
_ ScriptContext
p = TxInfo -> PubKeyHash -> Bool
V2.txSignedBy (ScriptContext -> TxInfo
V2.scriptContextTxInfo ScriptContext
p) (PaymentPubKeyHash -> PubKeyHash
unPaymentPubKeyHash PaymentPubKeyHash
pk')

data PubKeyContract

instance Scripts.ValidatorTypes PubKeyContract where
    type instance RedeemerType PubKeyContract = ()
    type instance DatumType PubKeyContract = ()

typedValidator :: PaymentPubKeyHash -> V2.TypedValidator PubKeyContract
typedValidator :: PaymentPubKeyHash -> TypedValidator PubKeyContract
typedValidator = CompiledCode (PaymentPubKeyHash -> ValidatorType PubKeyContract)
-> CompiledCode (ValidatorType PubKeyContract -> UntypedValidator)
-> PaymentPubKeyHash
-> TypedValidator PubKeyContract
forall a param.
Lift DefaultUni param =>
CompiledCode (param -> ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> param
-> TypedValidator a
V2.mkTypedValidatorParam @PubKeyContract
    $$(PlutusTx.compile [|| mkValidator ||])
    $$(PlutusTx.compile [|| wrap ||])
    where
        wrap :: (() -> () -> ScriptContext -> Bool) -> UntypedValidator
wrap = (() -> () -> ScriptContext -> Bool) -> UntypedValidator
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool) -> UntypedValidator
Scripts.mkUntypedValidator

data PubKeyError =
    ScriptOutputMissing PaymentPubKeyHash
    | MultipleScriptOutputs PaymentPubKeyHash
    | PKContractError ContractError
    deriving stock (PubKeyError -> PubKeyError -> Bool
(PubKeyError -> PubKeyError -> Bool)
-> (PubKeyError -> PubKeyError -> Bool) -> Eq PubKeyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PubKeyError -> PubKeyError -> Bool
$c/= :: PubKeyError -> PubKeyError -> Bool
== :: PubKeyError -> PubKeyError -> Bool
$c== :: PubKeyError -> PubKeyError -> Bool
Eq, Int -> PubKeyError -> ShowS
[PubKeyError] -> ShowS
PubKeyError -> String
(Int -> PubKeyError -> ShowS)
-> (PubKeyError -> String)
-> ([PubKeyError] -> ShowS)
-> Show PubKeyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PubKeyError] -> ShowS
$cshowList :: [PubKeyError] -> ShowS
show :: PubKeyError -> String
$cshow :: PubKeyError -> String
showsPrec :: Int -> PubKeyError -> ShowS
$cshowsPrec :: Int -> PubKeyError -> ShowS
Show, (forall x. PubKeyError -> Rep PubKeyError x)
-> (forall x. Rep PubKeyError x -> PubKeyError)
-> Generic PubKeyError
forall x. Rep PubKeyError x -> PubKeyError
forall x. PubKeyError -> Rep PubKeyError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PubKeyError x -> PubKeyError
$cfrom :: forall x. PubKeyError -> Rep PubKeyError x
Generic)
    deriving anyclass ([PubKeyError] -> Encoding
[PubKeyError] -> Value
PubKeyError -> Encoding
PubKeyError -> Value
(PubKeyError -> Value)
-> (PubKeyError -> Encoding)
-> ([PubKeyError] -> Value)
-> ([PubKeyError] -> Encoding)
-> ToJSON PubKeyError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [PubKeyError] -> Encoding
$ctoEncodingList :: [PubKeyError] -> Encoding
toJSONList :: [PubKeyError] -> Value
$ctoJSONList :: [PubKeyError] -> Value
toEncoding :: PubKeyError -> Encoding
$ctoEncoding :: PubKeyError -> Encoding
toJSON :: PubKeyError -> Value
$ctoJSON :: PubKeyError -> Value
ToJSON, Value -> Parser [PubKeyError]
Value -> Parser PubKeyError
(Value -> Parser PubKeyError)
-> (Value -> Parser [PubKeyError]) -> FromJSON PubKeyError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [PubKeyError]
$cparseJSONList :: Value -> Parser [PubKeyError]
parseJSON :: Value -> Parser PubKeyError
$cparseJSON :: Value -> Parser PubKeyError
FromJSON)

makeClassyPrisms ''PubKeyError

instance AsContractError PubKeyError where
    _ContractError :: p ContractError (f ContractError) -> p PubKeyError (f PubKeyError)
_ContractError = p ContractError (f ContractError) -> p PubKeyError (f PubKeyError)
forall r. AsPubKeyError r => Prism' r ContractError
_PKContractError

-- | Lock some funds in a 'PayToPubKey' contract, returning the output's address
--   and a 'TxIn' transaction input that can spend it.
pubKeyContract
    :: forall w s e.
    ( AsPubKeyError e
    )
    => PaymentPubKeyHash
    -> Value
    -> Contract w s e (TxOutRef, Maybe DecoratedTxOut, V2.TypedValidator PubKeyContract)
pubKeyContract :: PaymentPubKeyHash
-> Value
-> Contract
     w
     s
     e
     (TxOutRef, Maybe DecoratedTxOut, TypedValidator PubKeyContract)
pubKeyContract PaymentPubKeyHash
pk Value
vl = (PubKeyError -> e)
-> Contract
     w
     s
     PubKeyError
     (TxOutRef, Maybe DecoratedTxOut, TypedValidator PubKeyContract)
-> Contract
     w
     s
     e
     (TxOutRef, Maybe DecoratedTxOut, TypedValidator PubKeyContract)
forall w (s :: Row *) e e' a.
(e -> e') -> Contract w s e a -> Contract w s e' a
mapError (AReview e PubKeyError -> PubKeyError -> e
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview e PubKeyError
forall r. AsPubKeyError r => Prism' r PubKeyError
_PubKeyError) (Contract
   w
   s
   PubKeyError
   (TxOutRef, Maybe DecoratedTxOut, TypedValidator PubKeyContract)
 -> Contract
      w
      s
      e
      (TxOutRef, Maybe DecoratedTxOut, TypedValidator PubKeyContract))
-> Contract
     w
     s
     PubKeyError
     (TxOutRef, Maybe DecoratedTxOut, TypedValidator PubKeyContract)
-> Contract
     w
     s
     e
     (TxOutRef, Maybe DecoratedTxOut, TypedValidator PubKeyContract)
forall a b. (a -> b) -> a -> b
$ do
    NetworkId
networkId <- Params -> NetworkId
pNetworkId (Params -> NetworkId)
-> Contract w s PubKeyError Params
-> Contract w s PubKeyError NetworkId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Contract w s PubKeyError Params
forall w (s :: Row *) e. AsContractError e => Contract w s e Params
getParams
    let inst :: TypedValidator PubKeyContract
inst = PaymentPubKeyHash -> TypedValidator PubKeyContract
typedValidator PaymentPubKeyHash
pk
        address :: AddressInEra BabbageEra
address = NetworkId
-> TypedValidator PubKeyContract -> AddressInEra BabbageEra
forall a. NetworkId -> TypedValidator a -> AddressInEra BabbageEra
Scripts.validatorCardanoAddress NetworkId
networkId TypedValidator PubKeyContract
inst
        tx :: TxConstraints () ()
tx = () -> Value -> TxConstraints () ()
forall o i. o -> Value -> TxConstraints i o
Constraints.mustPayToTheScriptWithDatumInTx () Value
vl

    CardanoTx
ledgerTx <- ScriptLookups PubKeyContract
-> TxConstraints
     (RedeemerType PubKeyContract) (DatumType PubKeyContract)
-> Contract w s PubKeyError UnbalancedTx
forall a w (s :: Row *) e.
(ToData (RedeemerType a), FromData (DatumType a),
 ToData (DatumType a), AsContractError e) =>
ScriptLookups a
-> TxConstraints (RedeemerType a) (DatumType a)
-> Contract w s e UnbalancedTx
mkTxConstraints (TypedValidator PubKeyContract -> ScriptLookups PubKeyContract
forall a. TypedValidator a -> ScriptLookups a
Constraints.typedValidatorLookups TypedValidator PubKeyContract
inst) TxConstraints () ()
TxConstraints
  (RedeemerType PubKeyContract) (DatumType PubKeyContract)
tx
        Contract w s PubKeyError UnbalancedTx
-> (UnbalancedTx -> Contract w s PubKeyError UnbalancedTx)
-> Contract w s PubKeyError UnbalancedTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s PubKeyError UnbalancedTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e UnbalancedTx
adjustUnbalancedTx Contract w s PubKeyError UnbalancedTx
-> (UnbalancedTx -> Contract w s PubKeyError CardanoTx)
-> Contract w s PubKeyError CardanoTx
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UnbalancedTx -> Contract w s PubKeyError CardanoTx
forall w (s :: Row *) e.
AsContractError e =>
UnbalancedTx -> Contract w s e CardanoTx
submitUnbalancedTx

    ()
_ <- TxId -> Contract w s PubKeyError ()
forall w (s :: Row *) e.
AsContractError e =>
TxId -> Contract w s e ()
awaitTxConfirmed (CardanoTx -> TxId
getCardanoTxId CardanoTx
ledgerTx)
    let refs :: [TxIn]
refs = Map TxIn TxOut -> [TxIn]
forall k a. Map k a -> [k]
Map.keys
               (Map TxIn TxOut -> [TxIn]) -> Map TxIn TxOut -> [TxIn]
forall a b. (a -> b) -> a -> b
$ (TxOut -> Bool) -> Map TxIn TxOut -> Map TxIn TxOut
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (AddressInEra BabbageEra -> AddressInEra BabbageEra -> Bool
forall a. Eq a => a -> a -> Bool
(==) AddressInEra BabbageEra
address (AddressInEra BabbageEra -> Bool)
-> (TxOut -> AddressInEra BabbageEra) -> TxOut -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut -> AddressInEra BabbageEra
txOutAddress)
               (Map TxIn TxOut -> Map TxIn TxOut)
-> Map TxIn TxOut -> Map TxIn TxOut
forall a b. (a -> b) -> a -> b
$ CardanoTx -> Map TxIn TxOut
getCardanoTxProducedOutputs CardanoTx
ledgerTx

    case [TxIn]
refs of
        []                   -> AReview PubKeyError PaymentPubKeyHash
-> PaymentPubKeyHash
-> Contract
     w
     s
     PubKeyError
     (TxOutRef, Maybe DecoratedTxOut, TypedValidator PubKeyContract)
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview PubKeyError PaymentPubKeyHash
forall r. AsPubKeyError r => Prism' r PaymentPubKeyHash
_ScriptOutputMissing PaymentPubKeyHash
pk
        [TxIn
outRef] -> do
            -- TODO: THE FOLLOWING SHOULD BE REMOVED EVENTUALLY.
            -- Currently, the PAB indexes information about the status of
            -- transaction outputs. However, even if the transaction is
            -- confirmed, it might take some time in order for the chain-index
            -- to update it's database with the new confirmed transaction.
            -- Ultimately, the solution is to move indexed information by the
            -- PAB to the chain-index, so that we get a single source of truth.
            --
            -- The temporary solution is to use the 'awaitChainIndexSlot' call
            -- which waits until the chain-index is up to date. Meaning, the
            -- chain-index's synced slot should be at least as high as the
            -- current slot.
            --
            -- See https://plutus-apps.readthedocs.io/en/latest/adr/0002-pab-indexing-solution-integration.html"
            -- for the full explanation.
            --
            -- The 'awaitChainIndexSlot' blocks the contract until the chain-index
            -- is synced until the current slot. This is not a good solution,
            -- as the chain-index is always some time behind the current slot.
            Slot
slot <- Contract w s PubKeyError Slot
forall w (s :: Row *) e. AsContractError e => Contract w s e Slot
currentNodeClientSlot
            Slot -> Contract w s PubKeyError ()
forall e w (s :: Row *).
AsContractError e =>
Slot -> Contract w s e ()
awaitChainIndexSlot Slot
slot

            Maybe DecoratedTxOut
ciTxOut <- TxOutRef -> Contract w s PubKeyError (Maybe DecoratedTxOut)
forall w (s :: Row *) e.
AsContractError e =>
TxOutRef -> Contract w s e (Maybe DecoratedTxOut)
unspentTxOutFromRef (TxIn -> TxOutRef
fromCardanoTxIn TxIn
outRef)
            (TxOutRef, Maybe DecoratedTxOut, TypedValidator PubKeyContract)
-> Contract
     w
     s
     PubKeyError
     (TxOutRef, Maybe DecoratedTxOut, TypedValidator PubKeyContract)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxIn -> TxOutRef
fromCardanoTxIn TxIn
outRef, Maybe DecoratedTxOut
ciTxOut, TypedValidator PubKeyContract
inst)
        [TxIn]
_                    -> AReview PubKeyError PaymentPubKeyHash
-> PaymentPubKeyHash
-> Contract
     w
     s
     PubKeyError
     (TxOutRef, Maybe DecoratedTxOut, TypedValidator PubKeyContract)
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview PubKeyError PaymentPubKeyHash
forall r. AsPubKeyError r => Prism' r PaymentPubKeyHash
_MultipleScriptOutputs PaymentPubKeyHash
pk

-- | Temporary. Read TODO in 'pubKeyContract'.
awaitChainIndexSlot :: (AsContractError e) => Slot -> Contract w s e ()
awaitChainIndexSlot :: Slot -> Contract w s e ()
awaitChainIndexSlot Slot
targetSlot = do
    Tip
chainIndexTip <- Contract w s e Tip
forall w (s :: Row *) e. AsContractError e => Contract w s e Tip
getTip
    let chainIndexSlot :: Slot
chainIndexSlot = Tip -> Slot
getChainIndexSlot Tip
chainIndexTip
    if Slot
chainIndexSlot Slot -> Slot -> Bool
forall a. Ord a => a -> a -> Bool
< Slot
targetSlot
       then do
           Contract w s e Slot -> Contract w s e ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Contract w s e Slot -> Contract w s e ())
-> Contract w s e Slot -> Contract w s e ()
forall a b. (a -> b) -> a -> b
$ Natural -> Contract w s e Slot
forall w (s :: Row *) e.
AsContractError e =>
Natural -> Contract w s e Slot
waitNSlots Natural
1
           Slot -> Contract w s e ()
forall e w (s :: Row *).
AsContractError e =>
Slot -> Contract w s e ()
awaitChainIndexSlot Slot
targetSlot
       else
           () -> Contract w s e ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
    getChainIndexSlot :: Tip -> Slot
    getChainIndexSlot :: Tip -> Slot
getChainIndexSlot Tip
TipAtGenesis   = Integer -> Slot
Slot Integer
0
    getChainIndexSlot (Tip Slot
slot BlockId
_ BlockNumber
_) = Slot
slot