{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeOperators       #-}

module PlutusExample.PlutusVersion1.RedeemerContextScripts
  ( PV1CustomRedeemer(..)
  , pv1CustomRedeemerFromScriptData
  , scriptContextTestMintingScript
  , scriptContextTextPayingScript
  ) where

import Prelude hiding (($))

import Cardano.Api
import Cardano.Api.Shelley

import Codec.Serialise
import Data.ByteString.Lazy qualified as LB
import Data.ByteString.Short qualified as SBS

import Plutus.Script.Utils.Typed as Scripts
import Plutus.V1.Ledger.Api qualified as Plutus
import PlutusTx qualified
import PlutusTx.AssocMap qualified as AMap
import PlutusTx.Prelude hiding (Semigroup (..), unless, (.))
import PlutusTx.Prelude qualified as P

-- Description
-- PV1CustomRedeemer mimics the ScriptContext. PV1CustomRedeemer is built via reading
-- the transaction containing the script and the script itself just compares PV1CustomRedeemer
-- to the ScriptContext to be sure they are equivalent.
-- The overall aim is to make sure what is provided via ScriptContext (i.e. the transaction)
-- is what it's supposed to be. We check this by creating PV1CustomRedeemer based on
-- the actual transaction which is created via the create-script-context executable.


newtype MyCustomDatum = MyCustomDatum Integer

data PV1CustomRedeemer
  = PV1CustomRedeemer
      { PV1CustomRedeemer -> [TxOut]
mCrOutputs       :: [Plutus.TxOut]
      , PV1CustomRedeemer -> [TxInInfo]
mCrInputs        :: [Plutus.TxInInfo]
      , PV1CustomRedeemer -> Value
mCrMint          :: Plutus.Value
      , PV1CustomRedeemer -> POSIXTimeRange
mCrValidRange    :: Plutus.POSIXTimeRange
      , PV1CustomRedeemer -> Value
mCrFee           :: Plutus.Value
      , PV1CustomRedeemer -> [(DatumHash, Datum)]
mCrDatums        :: [(Plutus.DatumHash, Plutus.Datum)]
      , PV1CustomRedeemer -> [DCert]
mCrCerts         :: [Plutus.DCert]
      , PV1CustomRedeemer -> [PubKeyHash]
mCrSignatories   :: [Plutus.PubKeyHash]
      , PV1CustomRedeemer -> Maybe ScriptPurpose
mCrScriptPurpose :: Maybe Plutus.ScriptPurpose
      } deriving (PV1CustomRedeemer -> PV1CustomRedeemer -> Bool
(PV1CustomRedeemer -> PV1CustomRedeemer -> Bool)
-> (PV1CustomRedeemer -> PV1CustomRedeemer -> Bool)
-> Eq PV1CustomRedeemer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PV1CustomRedeemer -> PV1CustomRedeemer -> Bool
$c/= :: PV1CustomRedeemer -> PV1CustomRedeemer -> Bool
== :: PV1CustomRedeemer -> PV1CustomRedeemer -> Bool
$c== :: PV1CustomRedeemer -> PV1CustomRedeemer -> Bool
Prelude.Eq, Int -> PV1CustomRedeemer -> ShowS
[PV1CustomRedeemer] -> ShowS
PV1CustomRedeemer -> String
(Int -> PV1CustomRedeemer -> ShowS)
-> (PV1CustomRedeemer -> String)
-> ([PV1CustomRedeemer] -> ShowS)
-> Show PV1CustomRedeemer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PV1CustomRedeemer] -> ShowS
$cshowList :: [PV1CustomRedeemer] -> ShowS
show :: PV1CustomRedeemer -> String
$cshow :: PV1CustomRedeemer -> String
showsPrec :: Int -> PV1CustomRedeemer -> ShowS
$cshowsPrec :: Int -> PV1CustomRedeemer -> ShowS
Show)

PlutusTx.unstableMakeIsData ''MyCustomDatum
PlutusTx.unstableMakeIsData ''PV1CustomRedeemer

{-# INLINABLE mkValidator #-}
mkValidator :: MyCustomDatum-> PV1CustomRedeemer -> Plutus.ScriptContext -> Bool
mkValidator :: MyCustomDatum -> PV1CustomRedeemer -> ScriptContext -> Bool
mkValidator MyCustomDatum
_datum (PV1CustomRedeemer [TxOut]
txouts [TxInInfo]
txins Value
minted POSIXTimeRange
txValidRange Value
_fee [(DatumHash, Datum)]
datumsAndHashes [DCert]
certs [PubKeyHash]
signatories Maybe ScriptPurpose
mPurpose) ScriptContext
scriptContext =
  -- Minted field is equivalent
  TxInfo -> Value
Plutus.txInfoMint TxInfo
txInfo Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
P.== Value
minted Bool -> Bool -> Bool
P.&&
  -- Validity range is equivalent
  TxInfo -> POSIXTimeRange
Plutus.txInfoValidRange TxInfo
txInfo POSIXTimeRange -> POSIXTimeRange -> Bool
forall a. Eq a => a -> a -> Bool
P.== POSIXTimeRange
txValidRange Bool -> Bool -> Bool
P.&&
  -- Datums and datum hashes are equivalent
  TxInfo -> [(DatumHash, Datum)]
Plutus.txInfoData TxInfo
txInfo [(DatumHash, Datum)] -> [(DatumHash, Datum)] -> Bool
forall a. Eq a => a -> a -> Bool
P.== [(DatumHash, Datum)]
datumsAndHashes Bool -> Bool -> Bool
P.&&
  -- Required tx signers are equivalent
  TxInfo -> [PubKeyHash]
Plutus.txInfoSignatories TxInfo
txInfo [PubKeyHash] -> [PubKeyHash] -> Bool
forall a. Eq a => a -> a -> Bool
P.== [PubKeyHash]
signatories Bool -> Bool -> Bool
P.&&
  -- Payment tx out is equivalent
  Value -> Map Value Integer -> Bool
forall k v. Eq k => k -> Map k v -> Bool
AMap.member Value
paymentOutputFromRedeemer Map Value Integer
scriptContextOutputsMap Bool -> Bool -> Bool
P.&&
  -- Txins are equivalent
  (TxInInfo -> Map TxInInfo Integer -> Bool
forall k v. Eq k => k -> Map k v -> Bool
AMap.member TxInInfo
txinA Map TxInInfo Integer
scriptContextTxinsMap Bool -> Bool -> Bool
P.&& TxInInfo -> Map TxInInfo Integer -> Bool
forall k v. Eq k => k -> Map k v -> Bool
AMap.member TxInInfo
txinB Map TxInInfo Integer
scriptContextTxinsMap) Bool -> Bool -> Bool
P.&&
  -- Check if tx inputs are equivalent
  DCert -> Map DCert Integer -> Bool
forall k v. Eq k => k -> Map k v -> Bool
AMap.member DCert
singleRedeemerCert Map DCert Integer
scriptContextCertsMap Bool -> Bool -> Bool
P.&&
  -- Check if the script purposes are equivalent
  case Maybe ScriptPurpose
mPurpose of
    Just ScriptPurpose
sPurp -> ScriptPurpose
sPurp ScriptPurpose -> ScriptPurpose -> Bool
forall a. Eq a => a -> a -> Bool
P.== ScriptPurpose
sPurpose
    Maybe ScriptPurpose
Nothing    -> () -> Bool
forall a. () -> a
PlutusTx.Prelude.error ()
 where
   scriptContextCertsMap :: AMap.Map Plutus.DCert Integer
   scriptContextCertsMap :: Map DCert Integer
scriptContextCertsMap = [(DCert, Integer)] -> Map DCert Integer
forall k v. [(k, v)] -> Map k v
AMap.fromList ([(DCert, Integer)] -> Map DCert Integer)
-> [(DCert, Integer)] -> Map DCert Integer
forall a b. (a -> b) -> a -> b
P.$ [DCert] -> [Integer] -> [(DCert, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip (TxInfo -> [DCert]
Plutus.txInfoDCert TxInfo
txInfo) [Integer
1]

   singleRedeemerCert :: Plutus.DCert
   singleRedeemerCert :: DCert
singleRedeemerCert = [DCert] -> DCert
forall a. [a] -> a
P.head [DCert]
certs

   txinA :: Plutus.TxInInfo
   txinA :: TxInInfo
txinA = [TxInInfo] -> TxInInfo
forall a. [a] -> a
P.head [TxInInfo]
redeemerTxins

   txinB :: Plutus.TxInInfo
   txinB :: TxInInfo
txinB = [TxInInfo] -> TxInInfo
forall a. [a] -> a
P.head ([TxInInfo] -> TxInInfo) -> [TxInInfo] -> TxInInfo
forall a b. (a -> b) -> a -> b
$ [TxInInfo] -> [TxInInfo]
forall a. [a] -> [a]
P.reverse [TxInInfo]
redeemerTxins

   redeemerTxins :: [Plutus.TxInInfo]
   redeemerTxins :: [TxInInfo]
redeemerTxins = [TxInInfo]
txins

   scriptContextTxins :: [Plutus.TxInInfo]
   scriptContextTxins :: [TxInInfo]
scriptContextTxins = TxInfo -> [TxInInfo]
Plutus.txInfoInputs TxInfo
txInfo

   scriptContextTxinsMap :: AMap.Map Plutus.TxInInfo Integer
   scriptContextTxinsMap :: Map TxInInfo Integer
scriptContextTxinsMap = [(TxInInfo, Integer)] -> Map TxInInfo Integer
forall k v. [(k, v)] -> Map k v
AMap.fromList ([(TxInInfo, Integer)] -> Map TxInInfo Integer)
-> [(TxInInfo, Integer)] -> Map TxInInfo Integer
forall a b. (a -> b) -> a -> b
P.$ [TxInInfo] -> [Integer] -> [(TxInInfo, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [TxInInfo]
scriptContextTxins [Integer
1,Integer
2 :: Integer]

   -- This is paid to the dummy address. We can't compute the change address amount
   -- because the redeemer we computed is based on an older tx which affects the fee
   -- and therefore the change address amount.
   paymentOutputFromRedeemer :: Plutus.Value
   paymentOutputFromRedeemer :: Value
paymentOutputFromRedeemer = [Value] -> Value
forall a. [a] -> a
P.head ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> [Value]
forall a. [a] -> [a]
P.reverse [Value]
redeemerValues

   redeemerValues :: [Plutus.Value]
   redeemerValues :: [Value]
redeemerValues = (TxOut -> Value) -> [TxOut] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
P.map TxOut -> Value
Plutus.txOutValue [TxOut]
txouts

   scriptContextOutputValues :: [Plutus.Value]
   scriptContextOutputValues :: [Value]
scriptContextOutputValues = (TxOut -> Value) -> [TxOut] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
P.map TxOut -> Value
Plutus.txOutValue ([TxOut] -> [Value]) -> [TxOut] -> [Value]
forall a b. (a -> b) -> a -> b
$ TxInfo -> [TxOut]
Plutus.txInfoOutputs TxInfo
txInfo

   scriptContextOutputsMap :: AMap.Map Plutus.Value Integer
   scriptContextOutputsMap :: Map Value Integer
scriptContextOutputsMap = [(Value, Integer)] -> Map Value Integer
forall k v. [(k, v)] -> Map k v
AMap.fromList ([(Value, Integer)] -> Map Value Integer)
-> [(Value, Integer)] -> Map Value Integer
forall a b. (a -> b) -> a -> b
P.$ [Value] -> [Integer] -> [(Value, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Value]
scriptContextOutputValues [Integer
1,Integer
2 :: Integer]

   txInfo :: Plutus.TxInfo
   txInfo :: TxInfo
txInfo = ScriptContext -> TxInfo
Plutus.scriptContextTxInfo ScriptContext
scriptContext

   sPurpose :: Plutus.ScriptPurpose
   sPurpose :: ScriptPurpose
sPurpose = ScriptContext -> ScriptPurpose
Plutus.scriptContextPurpose ScriptContext
scriptContext

validator :: Plutus.Validator
validator :: Validator
validator = CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ())
-> Validator
Plutus.mkValidatorScript
    $$(PlutusTx.compile [|| wrap ||])
  where
    wrap :: BuiltinData -> BuiltinData -> BuiltinData -> ()
wrap = (MyCustomDatum -> PV1CustomRedeemer -> ScriptContext -> Bool)
-> BuiltinData -> BuiltinData -> BuiltinData -> ()
forall sc d r.
(IsScriptContext sc, UnsafeFromData d, UnsafeFromData r) =>
(d -> r -> sc -> Bool)
-> BuiltinData -> BuiltinData -> BuiltinData -> ()
Scripts.mkUntypedValidator MyCustomDatum -> PV1CustomRedeemer -> ScriptContext -> Bool
mkValidator

plutusV1RedeemerContextTestScript :: Plutus.Script
plutusV1RedeemerContextTestScript :: Script
plutusV1RedeemerContextTestScript = Validator -> Script
Plutus.unValidatorScript Validator
validator

pv1RedeemerContextTestScriptBs :: SBS.ShortByteString
pv1RedeemerContextTestScriptBs :: ShortByteString
pv1RedeemerContextTestScriptBs = ByteString -> ShortByteString
SBS.toShort (ByteString -> ShortByteString)
-> (ByteString -> ByteString) -> ByteString -> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LB.toStrict (ByteString -> ShortByteString) -> ByteString -> ShortByteString
forall a b. (a -> b) -> a -> b
$ Script -> ByteString
forall a. Serialise a => a -> ByteString
serialise Script
plutusV1RedeemerContextTestScript

scriptContextTextPayingScript :: PlutusScript PlutusScriptV1
scriptContextTextPayingScript :: PlutusScript PlutusScriptV1
scriptContextTextPayingScript = ShortByteString -> PlutusScript PlutusScriptV1
forall lang. ShortByteString -> PlutusScript lang
PlutusScriptSerialised ShortByteString
pv1RedeemerContextTestScriptBs


-- Minting script that checks the minting value, validty interval and
-- required signers in the ScriptContext is equivalent to what's in the
-- redeemer.

{-# INLINABLE mkPolicy #-}
mkPolicy :: PV1CustomRedeemer -> Plutus.ScriptContext -> Bool
mkPolicy :: PV1CustomRedeemer -> ScriptContext -> Bool
mkPolicy (PV1CustomRedeemer [TxOut]
_ [TxInInfo]
_ Value
minted POSIXTimeRange
txValidRange Value
_fee [(DatumHash, Datum)]
_ [DCert]
_ [PubKeyHash]
signatories Maybe ScriptPurpose
mPurpose) ScriptContext
scriptContext =
  -- Minted value is equivalent
  Value
minted Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
P.== TxInfo -> Value
Plutus.txInfoMint TxInfo
txInfo Bool -> Bool -> Bool
P.&&
  -- Validity range is equivalent
  TxInfo -> POSIXTimeRange
Plutus.txInfoValidRange TxInfo
txInfo POSIXTimeRange -> POSIXTimeRange -> Bool
forall a. Eq a => a -> a -> Bool
P.== POSIXTimeRange
txValidRange Bool -> Bool -> Bool
P.&&
  -- Required signers are equivalent
  PubKeyHash -> Map PubKeyHash Integer -> Bool
forall k v. Eq k => k -> Map k v -> Bool
AMap.member PubKeyHash
singleSignatory Map PubKeyHash Integer
scriptContextSignatoriesMap Bool -> Bool -> Bool
P.&&

  case Maybe ScriptPurpose
mPurpose of
    Just ScriptPurpose
sPurp -> ScriptPurpose
sPurp ScriptPurpose -> ScriptPurpose -> Bool
forall a. Eq a => a -> a -> Bool
P.== ScriptPurpose
sPurpose
    Maybe ScriptPurpose
Nothing    -> () -> Bool
forall a. () -> a
PlutusTx.Prelude.error ()
 where
   sPurpose :: Plutus.ScriptPurpose
   sPurpose :: ScriptPurpose
sPurpose = ScriptContext -> ScriptPurpose
Plutus.scriptContextPurpose ScriptContext
scriptContext

   scriptContextSignatoriesMap :: AMap.Map Plutus.PubKeyHash Integer
   scriptContextSignatoriesMap :: Map PubKeyHash Integer
scriptContextSignatoriesMap = [(PubKeyHash, Integer)] -> Map PubKeyHash Integer
forall k v. [(k, v)] -> Map k v
AMap.fromList ([(PubKeyHash, Integer)] -> Map PubKeyHash Integer)
-> [(PubKeyHash, Integer)] -> Map PubKeyHash Integer
forall a b. (a -> b) -> a -> b
P.$ [PubKeyHash] -> [Integer] -> [(PubKeyHash, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip (TxInfo -> [PubKeyHash]
Plutus.txInfoSignatories TxInfo
txInfo) [Integer
1]

   singleSignatory :: Plutus.PubKeyHash
   singleSignatory :: PubKeyHash
singleSignatory = [PubKeyHash] -> PubKeyHash
forall a. [a] -> a
P.head [PubKeyHash]
signatories

   txInfo :: Plutus.TxInfo
   txInfo :: TxInfo
txInfo = ScriptContext -> TxInfo
Plutus.scriptContextTxInfo ScriptContext
scriptContext

mintingScriptContextTextPolicy :: Plutus.MintingPolicy
mintingScriptContextTextPolicy :: MintingPolicy
mintingScriptContextTextPolicy = CompiledCode (BuiltinData -> BuiltinData -> ()) -> MintingPolicy
Plutus.mkMintingPolicyScript
           $$(PlutusTx.compile [|| wrap ||])
 where
   wrap :: BuiltinData -> BuiltinData -> ()
wrap = (PV1CustomRedeemer -> ScriptContext -> Bool)
-> BuiltinData -> BuiltinData -> ()
forall sc r.
(IsScriptContext sc, UnsafeFromData r) =>
(r -> sc -> Bool) -> BuiltinData -> BuiltinData -> ()
Scripts.mkUntypedMintingPolicy PV1CustomRedeemer -> ScriptContext -> Bool
mkPolicy

plutusV1RedeemerContextTestMintingScript :: Plutus.Script
plutusV1RedeemerContextTestMintingScript :: Script
plutusV1RedeemerContextTestMintingScript =
  MintingPolicy -> Script
Plutus.unMintingPolicyScript MintingPolicy
mintingScriptContextTextPolicy

scriptContextTextMintingValidator :: Plutus.Validator
scriptContextTextMintingValidator :: Validator
scriptContextTextMintingValidator =
  Script -> Validator
Plutus.Validator Script
plutusV1RedeemerContextTestMintingScript

scriptContextTextMintingScript :: LB.ByteString
scriptContextTextMintingScript :: ByteString
scriptContextTextMintingScript = Validator -> ByteString
forall a. Serialise a => a -> ByteString
serialise Validator
scriptContextTextMintingValidator

scriptContextTestMintingScript :: PlutusScript PlutusScriptV1
scriptContextTestMintingScript :: PlutusScript PlutusScriptV1
scriptContextTestMintingScript = ShortByteString -> PlutusScript PlutusScriptV1
forall lang. ShortByteString -> PlutusScript lang
PlutusScriptSerialised (ShortByteString -> PlutusScript PlutusScriptV1)
-> (ByteString -> ShortByteString)
-> ByteString
-> PlutusScript PlutusScriptV1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
SBS.toShort (ByteString -> PlutusScript PlutusScriptV1)
-> ByteString -> PlutusScript PlutusScriptV1
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LB.toStrict ByteString
scriptContextTextMintingScript

-- Helpers

pv1CustomRedeemerFromScriptData :: ScriptData -> Either String PV1CustomRedeemer
pv1CustomRedeemerFromScriptData :: ScriptData -> Either String PV1CustomRedeemer
pv1CustomRedeemerFromScriptData ScriptData
sDat =
  let bIData :: BuiltinData
bIData = Data -> BuiltinData
PlutusTx.dataToBuiltinData (Data -> BuiltinData) -> Data -> BuiltinData
forall a b. (a -> b) -> a -> b
$ ScriptData -> Data
toPlutusData ScriptData
sDat
  in case BuiltinData -> Maybe PV1CustomRedeemer
forall a. FromData a => BuiltinData -> Maybe a
PlutusTx.fromBuiltinData BuiltinData
bIData of
      Just PV1CustomRedeemer
mCRedeem -> PV1CustomRedeemer -> Either String PV1CustomRedeemer
forall a b. b -> Either a b
Right PV1CustomRedeemer
mCRedeem
      Maybe PV1CustomRedeemer
Nothing       -> String -> Either String PV1CustomRedeemer
forall a b. a -> Either a b
Left String
"Could not decode PV1CustomRedeemer from ScriptData"