RolePayout.hs

{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.0.0 #-}

module PlutusBenchmark.Marlowe.Scripts.RolePayout (
  rolePayoutValidatorHash,
  rolePayoutValidatorBytes,
  rolePayoutValidator,
  mkRolePayoutValidator,
) where

import Cardano.Crypto.Hash qualified as Hash
import Data.ByteString qualified as BS
import Data.ByteString.Short qualified as SBS
import PlutusLedgerApi.V1.Value qualified as Val
import PlutusLedgerApi.V2 (CurrencySymbol, ScriptContext (scriptContextTxInfo), ScriptHash (..),
                           SerialisedScript, TokenName, serialiseCompiledCode)
import PlutusLedgerApi.V2.Contexts (valueSpent)
import PlutusTx (CompiledCode, unsafeFromBuiltinData)
import PlutusTx qualified
import PlutusTx.Plugin ()
import PlutusTx.Prelude as PlutusTxPrelude (Bool (..), BuiltinData, BuiltinUnit, check, toBuiltin,
                                            ($), (.))

-- | Tag for the Marlowe payout validator.
data TypedRolePayoutValidator

-- | The Marlowe payout validator.
mkRolePayoutValidator
  :: (CurrencySymbol, TokenName)
  -- ^ The datum is the currency symbol and role name for the payout.
  -> ()
  -- ^ No redeemer is required.
  -> ScriptContext
  -- ^ The script context.
  -> Bool
  -- ^ Whether the transaction validated.
mkRolePayoutValidator (currency, role) _ ctx =
  -- The role token for the correct currency must be present.
  -- [Marlowe-Cardano Specification: "17. Payment authorized".]
  Val.singleton currency role 1 `Val.leq` valueSpent (scriptContextTxInfo ctx)

-- | Compute the hash of a script.
hashScript
  :: CompiledCode
       ( BuiltinData
         -> BuiltinData
         -> BuiltinData
         -> BuiltinUnit
       )
  -> ScriptHash
hashScript =
  -- FIXME: Apparently this is the wrong recipe, since its hash disagrees with
  -- `cardano-cli`.
  ScriptHash
    . toBuiltin
    . ( Hash.hashToBytes
          :: Hash.Hash Hash.Blake2b_224 SBS.ShortByteString
          -> BS.ByteString
      )
    . Hash.hashWith (BS.append "\x02" . SBS.fromShort) -- For Plutus V2.
    . serialiseCompiledCode

{-# INLINEABLE rolePayoutValidator #-}

-- | The Marlowe payout validator.
rolePayoutValidator
  :: CompiledCode
       ( BuiltinData
         -> BuiltinData
         -> BuiltinData
         -> BuiltinUnit
       )
rolePayoutValidator = $$(PlutusTx.compile [||rolePayoutValidator'||])
 where
  rolePayoutValidator'
    :: BuiltinData
    -> BuiltinData
    -> BuiltinData
    -> BuiltinUnit
  rolePayoutValidator' d r p =
    check
      $ mkRolePayoutValidator
        (unsafeFromBuiltinData d)
        (unsafeFromBuiltinData r)
        (unsafeFromBuiltinData p)

-- | The serialisation of the Marlowe payout validator.
rolePayoutValidatorBytes :: SerialisedScript
rolePayoutValidatorBytes = serialiseCompiledCode rolePayoutValidator

-- | The hash of the Marlowe payout validator.
rolePayoutValidatorHash :: ScriptHash
rolePayoutValidatorHash = hashScript rolePayoutValidator