{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-specialize #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:conservative-optimisation #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
-- Plutus core version to compile to. In babbage era, that is Cardano protocol
-- version 7 and 8, only plutus-core version 1.0.0 is available.
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-}

-- | The initial validator which allows participants to commit or abort.
module Hydra.Contract.Initial where

import PlutusTx.Prelude

import Hydra.Cardano.Api (PlutusScriptVersion (..))
import Hydra.Contract.Commit (Commit (..))
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.Error (errorCode)
import Hydra.Contract.InitialError (InitialError (..))
import Hydra.Contract.Util (findTxInByTxOutRef, mustBurnST, scriptOutputsAt, valueLockedBy)
import Hydra.Plutus (commitValidatorScript)
import Hydra.Plutus.Extras (ValidatorType, scriptValidatorHash, wrapValidator)
import PlutusCore.Core (plcVersion110)
import PlutusLedgerApi.Common (SerialisedScript, serialiseCompiledCode)
import PlutusLedgerApi.V1.Value (geq, isZero)
import PlutusLedgerApi.V3 (
  CurrencySymbol,
  Datum (..),
  FromData (fromBuiltinData),
  OutputDatum (..),
  PubKeyHash (getPubKeyHash),
  Redeemer (Redeemer),
  ScriptContext (..),
  ScriptHash,
  ToData (toBuiltinData),
  TokenName (unTokenName),
  TxInInfo (..),
  TxInfo (..),
  TxOut (txOutValue),
  TxOutRef,
  Value (getValue),
 )
import PlutusLedgerApi.V3.Contexts (findOwnInput)
import PlutusTx (CompiledCode)
import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap
import PlutusTx.Builtins qualified as Builtins

data InitialRedeemer
  = ViaAbort
  | ViaCommit
      { RedeemerType -> [TxOutRef]
committedRefs :: [TxOutRef]
      -- ^ Points to the committed Utxo.
      }

PlutusTx.unstableMakeIsData ''InitialRedeemer

type DatumType = CurrencySymbol
type RedeemerType = InitialRedeemer

-- | The v_initial validator verifies that:
--
--   * spent in a transaction also consuming a v_head output
--
--   * ensures the committed value is recorded correctly in the output datum
--
--   * ensures that the transaction was signed by the key corresponding to the
--     PubKeyHash encoded in the participation token name
--
-- NOTE: It does not need to ensure that the participation token is of some
-- specific Head currency.
validator ::
  -- | Hash of the commit validator
  ScriptHash ->
  DatumType ->
  RedeemerType ->
  ScriptContext ->
  Bool
validator :: ScriptHash -> DatumType -> RedeemerType -> ScriptContext -> Bool
validator ScriptHash
commitValidator DatumType
headId RedeemerType
red ScriptContext
context =
  case RedeemerType
red of
    RedeemerType
ViaAbort ->
      BuiltinString -> Bool -> Bool
traceIfFalse
        $(errorCode STNotBurned)
        (Value -> DatumType -> Bool
mustBurnST (TxInfo -> Value
txInfoMint (TxInfo -> Value) -> TxInfo -> Value
forall a b. (a -> b) -> a -> b
$ ScriptContext -> TxInfo
scriptContextTxInfo ScriptContext
context) DatumType
headId)
    ViaCommit{[TxOutRef]
committedRefs :: RedeemerType -> [TxOutRef]
committedRefs :: [TxOutRef]
committedRefs} ->
      ScriptHash -> DatumType -> [TxOutRef] -> ScriptContext -> Bool
checkCommit ScriptHash
commitValidator DatumType
headId [TxOutRef]
committedRefs ScriptContext
context

checkCommit ::
  -- | Hash of the commit validator
  ScriptHash ->
  -- | Head id
  CurrencySymbol ->
  [TxOutRef] ->
  ScriptContext ->
  Bool
checkCommit :: ScriptHash -> DatumType -> [TxOutRef] -> ScriptContext -> Bool
checkCommit ScriptHash
commitValidator DatumType
headId [TxOutRef]
committedRefs ScriptContext
context =
  Bool
checkCommittedValue
    Bool -> Bool -> Bool
&& Bool
checkLockedCommit
    Bool -> Bool -> Bool
&& Bool
checkHeadId
    Bool -> Bool -> Bool
&& Bool
mustBeSignedByParticipant
    Bool -> Bool -> Bool
&& Bool
mustNotMintOrBurn
 where
  checkCommittedValue :: Bool
checkCommittedValue =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode LockedValueDoesNotMatch) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      -- NOTE: Ada in initialValue is usually lower than in the locked ADA due
      -- to higher deposit needed for commit output than for initial output
      Value
lockedValue Value -> Value -> Bool
`geq` (Value
initialValue Value -> Value -> Value
forall a. AdditiveSemigroup a => a -> a -> a
+ Value
committedValue)

  checkLockedCommit :: Bool
checkLockedCommit =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode MismatchCommittedTxOutInDatum) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      ([TxInInfo], [Commit]) -> Bool
go ([TxInInfo]
committedUTxO, [Commit]
lockedCommits)
   where
    go :: ([TxInInfo], [Commit]) -> Bool
go = \case
      ([], []) ->
        Bool
True
      ([], Commit
_ : [Commit]
_) ->
        BuiltinString -> Bool
forall a. BuiltinString -> a
traceError $(errorCode MissingCommittedTxOutInOutputDatum)
      (TxInInfo
_ : [TxInInfo]
_, []) ->
        BuiltinString -> Bool
forall a. BuiltinString -> a
traceError $(errorCode CommittedTxOutMissingInOutputDatum)
      (TxInInfo{TxOutRef
txInInfoOutRef :: TxOutRef
txInInfoOutRef :: TxInInfo -> TxOutRef
txInInfoOutRef, TxOut
txInInfoResolved :: TxOut
txInInfoResolved :: TxInInfo -> TxOut
txInInfoResolved} : [TxInInfo]
restCommitted, Commit{TxOutRef
input :: TxOutRef
input :: Commit -> TxOutRef
input, BuiltinByteString
preSerializedOutput :: BuiltinByteString
preSerializedOutput :: Commit -> BuiltinByteString
preSerializedOutput} : [Commit]
restCommits) ->
        BuiltinData -> BuiltinByteString
Builtins.serialiseData (TxOut -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData TxOut
txInInfoResolved) BuiltinByteString -> BuiltinByteString -> Bool
forall a. Eq a => a -> a -> Bool
== BuiltinByteString
preSerializedOutput
          Bool -> Bool -> Bool
&& TxOutRef
txInInfoOutRef TxOutRef -> TxOutRef -> Bool
forall a. Eq a => a -> a -> Bool
== TxOutRef
input
          Bool -> Bool -> Bool
&& ([TxInInfo], [Commit]) -> Bool
go ([TxInInfo]
restCommitted, [Commit]
restCommits)

  checkHeadId :: Bool
checkHeadId =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode WrongHeadIdInCommitDatum) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      DatumType
headId' DatumType -> DatumType -> Bool
forall a. Eq a => a -> a -> Bool
== DatumType
headId

  mustBeSignedByParticipant :: Bool
mustBeSignedByParticipant =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode MissingOrInvalidCommitAuthor) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      TokenName -> BuiltinByteString
unTokenName TokenName
ourParticipationTokenName BuiltinByteString -> [BuiltinByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
`elem` (PubKeyHash -> BuiltinByteString
getPubKeyHash (PubKeyHash -> BuiltinByteString)
-> [PubKeyHash] -> [BuiltinByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxInfo -> [PubKeyHash]
txInfoSignatories TxInfo
txInfo)

  mustNotMintOrBurn :: Bool
mustNotMintOrBurn =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode MintingOrBurningIsForbidden) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      Value -> Bool
isZero (Value -> Bool) -> Value -> Bool
forall a b. (a -> b) -> a -> b
$
        TxInfo -> Value
txInfoMint TxInfo
txInfo

  ourParticipationTokenName :: TokenName
ourParticipationTokenName =
    case DatumType
-> Map DatumType (Map TokenName Integer)
-> Maybe (Map TokenName Integer)
forall k v. Eq k => k -> Map k v -> Maybe v
AssocMap.lookup DatumType
headId (Value -> Map DatumType (Map TokenName Integer)
getValue Value
initialValue) of
      Maybe (Map TokenName Integer)
Nothing -> BuiltinString -> TokenName
forall a. BuiltinString -> a
traceError $(errorCode CouldNotFindTheCorrectCurrencySymbolInTokens)
      Just Map TokenName Integer
tokenMap ->
        case Map TokenName Integer -> [(TokenName, Integer)]
forall k v. Map k v -> [(k, v)]
AssocMap.toList Map TokenName Integer
tokenMap of
          [(TokenName
tk, Integer
q)] | Integer
q Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 -> TokenName
tk
          [(TokenName, Integer)]
_moreThanOneToken -> BuiltinString -> TokenName
forall a. BuiltinString -> a
traceError $(errorCode MultipleHeadTokensOrMoreThan1PTsFound)

  initialValue :: Value
initialValue =
    Value -> (TxInInfo -> Value) -> Maybe TxInInfo -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
forall a. Monoid a => a
mempty (TxOut -> Value
txOutValue (TxOut -> Value) -> (TxInInfo -> TxOut) -> TxInInfo -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxInInfo -> TxOut
txInInfoResolved) (Maybe TxInInfo -> Value) -> Maybe TxInInfo -> Value
forall a b. (a -> b) -> a -> b
$ ScriptContext -> Maybe TxInInfo
findOwnInput ScriptContext
context

  committedValue :: Value
committedValue =
    (TxInInfo -> Value) -> [TxInInfo] -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (TxOut -> Value
txOutValue (TxOut -> Value) -> (TxInInfo -> TxOut) -> TxInInfo -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxInInfo -> TxOut
txInInfoResolved) [TxInInfo]
committedUTxO

  committedUTxO :: [TxInInfo]
committedUTxO = do
    ((TxOutRef -> TxInInfo) -> [TxOutRef] -> [TxInInfo])
-> [TxOutRef] -> (TxOutRef -> TxInInfo) -> [TxInInfo]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TxOutRef -> TxInInfo) -> [TxOutRef] -> [TxInInfo]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TxOutRef]
committedRefs ((TxOutRef -> TxInInfo) -> [TxInInfo])
-> (TxOutRef -> TxInInfo) -> [TxInInfo]
forall a b. (a -> b) -> a -> b
$ \TxOutRef
ref ->
      case TxOutRef -> TxInfo -> Maybe TxInInfo
findTxInByTxOutRef TxOutRef
ref TxInfo
txInfo of
        Maybe TxInInfo
Nothing -> BuiltinString -> TxInInfo
forall a. BuiltinString -> a
traceError $(errorCode OutRefNotFound)
        Just TxInInfo
txInInfo -> TxInInfo
txInInfo

  lockedValue :: Value
lockedValue = TxInfo -> ScriptHash -> Value
valueLockedBy TxInfo
txInfo ScriptHash
commitValidator

  ([Commit]
lockedCommits, DatumType
headId') =
    case ScriptHash -> TxInfo -> [(OutputDatum, Value)]
scriptOutputsAt ScriptHash
commitValidator TxInfo
txInfo of
      [(OutputDatum
dat, Value
_)] ->
        case OutputDatum
dat of
          OutputDatum
NoOutputDatum -> BuiltinString -> ([Commit], DatumType)
forall a. BuiltinString -> a
traceError $(errorCode MissingDatum)
          OutputDatumHash DatumHash
_dh ->
            BuiltinString -> ([Commit], DatumType)
forall a. BuiltinString -> a
traceError $(errorCode UnexpectedNonInlineDatum)
          OutputDatum Datum
da ->
            case forall a. FromData a => BuiltinData -> Maybe a
fromBuiltinData @Commit.DatumType (BuiltinData -> Maybe DatumType) -> BuiltinData -> Maybe DatumType
forall a b. (a -> b) -> a -> b
$ Datum -> BuiltinData
getDatum Datum
da of
              Maybe DatumType
Nothing -> BuiltinString -> ([Commit], DatumType)
forall a. BuiltinString -> a
traceError $(errorCode ExpectedCommitDatumTypeGotSomethingElse)
              Just (Party
_party, [Commit]
commits, DatumType
hid) ->
                ([Commit]
commits, DatumType
hid)
      [(OutputDatum, Value)]
_ -> BuiltinString -> ([Commit], DatumType)
forall a. BuiltinString -> a
traceError $(errorCode ExpectedSingleCommitOutput)

  ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo = TxInfo
txInfo} = ScriptContext
context

compiledValidator :: CompiledCode ValidatorType
compiledValidator :: CompiledCode ValidatorType
compiledValidator =
  $$(PlutusTx.compile [||wrap . validator||])
    CompiledCode (ScriptHash -> ValidatorType)
-> CompiledCodeIn DefaultUni DefaultFun ScriptHash
-> CompiledCode ValidatorType
forall (uni :: * -> *) fun a b.
(Closed uni, Everywhere uni Flat, Flat fun, Pretty fun,
 Everywhere uni PrettyConst,
 PrettyBy RenderContext (SomeTypeIn uni)) =>
CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b
`PlutusTx.unsafeApplyCode` Version
-> ScriptHash -> CompiledCodeIn DefaultUni DefaultFun ScriptHash
forall (uni :: * -> *) a fun.
(Lift uni a, GEq uni, ThrowableBuiltins uni fun,
 Typecheckable uni fun, Default (CostingPart uni fun),
 Default (BuiltinsInfo uni fun), Default (RewriteRules uni fun),
 Hashable fun) =>
Version -> a -> CompiledCodeIn uni fun a
PlutusTx.liftCode Version
plcVersion110 (PlutusScriptVersion PlutusScriptV3
-> SerialisedScript -> ScriptHash
forall lang.
PlutusScriptVersion lang -> SerialisedScript -> ScriptHash
scriptValidatorHash PlutusScriptVersion PlutusScriptV3
PlutusScriptV3 SerialisedScript
commitValidatorScript)
 where
  wrap :: (DatumType -> RedeemerType -> ScriptContext -> Bool)
-> ValidatorType
wrap = forall datum redeemer.
(UnsafeFromData datum, UnsafeFromData redeemer) =>
(datum -> redeemer -> ScriptContext -> Bool) -> ValidatorType
wrapValidator @DatumType @RedeemerType

validatorScript :: SerialisedScript
validatorScript :: SerialisedScript
validatorScript = CompiledCode ValidatorType -> SerialisedScript
forall a. CompiledCode a -> SerialisedScript
serialiseCompiledCode CompiledCode ValidatorType
compiledValidator

validatorHash :: ScriptHash
validatorHash :: ScriptHash
validatorHash = PlutusScriptVersion PlutusScriptV3
-> SerialisedScript -> ScriptHash
forall lang.
PlutusScriptVersion lang -> SerialisedScript -> ScriptHash
scriptValidatorHash PlutusScriptVersion PlutusScriptV3
PlutusScriptV3 SerialisedScript
validatorScript

datum :: DatumType -> Datum
datum :: DatumType -> Datum
datum DatumType
a = BuiltinData -> Datum
Datum (DatumType -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData DatumType
a)

redeemer :: RedeemerType -> Redeemer
redeemer :: RedeemerType -> Redeemer
redeemer RedeemerType
a = BuiltinData -> Redeemer
Redeemer (RedeemerType -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData RedeemerType
a)