{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-specialize #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
-- Avoid trace calls to be optimized away when inlining functions.
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-simplifier-inline #-}
-- 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.0.0 #-}

module Hydra.Contract.Head where

import PlutusTx.Prelude

import Hydra.Cardano.Api (PlutusScriptVersion (PlutusScriptV2))
import Hydra.Contract.Commit (Commit (..))
import Hydra.Contract.Commit qualified as Commit
import Hydra.Contract.HeadError (HeadError (..), errorCode)
import Hydra.Contract.HeadState (Input (..), Signature, SnapshotNumber, State (..))
import Hydra.Contract.Util (hasST, mustBurnAllHeadTokens, mustNotMintOrBurn, (===))
import Hydra.Data.ContestationPeriod (ContestationPeriod, addContestationPeriod, milliseconds)
import Hydra.Data.Party (Party (vkey))
import Hydra.Plutus.Extras (ValidatorType, scriptValidatorHash, wrapValidator)
import PlutusLedgerApi.Common (SerialisedScript, serialiseCompiledCode)
import PlutusLedgerApi.V1.Time (fromMilliSeconds)
import PlutusLedgerApi.V1.Value (valueOf)
import PlutusLedgerApi.V2 (
  Address,
  CurrencySymbol,
  Datum (..),
  Extended (Finite),
  FromData (fromBuiltinData),
  Interval (..),
  LowerBound (LowerBound),
  OutputDatum (..),
  POSIXTime,
  PubKeyHash (getPubKeyHash),
  ScriptContext (..),
  ScriptHash,
  ToData (toBuiltinData),
  TokenName (..),
  TxInInfo (..),
  TxInfo (..),
  TxOut (..),
  TxOutRef (..),
  UpperBound (..),
  Value (Value),
  adaSymbol,
  adaToken,
 )
import PlutusLedgerApi.V2.Contexts (findOwnInput)
import PlutusTx (CompiledCode)
import PlutusTx qualified
import PlutusTx.AssocMap qualified as AssocMap
import PlutusTx.Builtins qualified as Builtins

type DatumType = State
type RedeemerType = Input

--------------------------------------------------------------------------------
-- Validators
--------------------------------------------------------------------------------

{-# INLINEABLE headValidator #-}
headValidator ::
  State ->
  Input ->
  ScriptContext ->
  Bool
headValidator :: DatumType -> Input -> ScriptContext -> Bool
headValidator DatumType
oldState Input
input ScriptContext
ctx =
  case (DatumType
oldState, Input
input) of
    (Initial{ContestationPeriod
contestationPeriod :: ContestationPeriod
$sel:contestationPeriod:Initial :: DatumType -> ContestationPeriod
contestationPeriod, [Party]
parties :: [Party]
$sel:parties:Initial :: DatumType -> [Party]
parties, CurrencySymbol
headId :: CurrencySymbol
$sel:headId:Initial :: DatumType -> CurrencySymbol
headId}, Input
CollectCom) ->
      ScriptContext
-> (ContestationPeriod, [Party], CurrencySymbol) -> Bool
checkCollectCom ScriptContext
ctx (ContestationPeriod
contestationPeriod, [Party]
parties, CurrencySymbol
headId)
    (Initial{[Party]
$sel:parties:Initial :: DatumType -> [Party]
parties :: [Party]
parties, CurrencySymbol
$sel:headId:Initial :: DatumType -> CurrencySymbol
headId :: CurrencySymbol
headId}, Input
Abort) ->
      ScriptContext -> CurrencySymbol -> [Party] -> Bool
checkAbort ScriptContext
ctx CurrencySymbol
headId [Party]
parties
    (Open{[Party]
$sel:parties:Initial :: DatumType -> [Party]
parties :: [Party]
parties, $sel:utxoHash:Initial :: DatumType -> BuiltinByteString
utxoHash = BuiltinByteString
initialUtxoHash, ContestationPeriod
$sel:contestationPeriod:Initial :: DatumType -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, CurrencySymbol
$sel:headId:Initial :: DatumType -> CurrencySymbol
headId :: CurrencySymbol
headId}, Close{[BuiltinByteString]
signature :: [BuiltinByteString]
$sel:signature:CollectCom :: Input -> [BuiltinByteString]
signature}) ->
      ScriptContext
-> [Party]
-> BuiltinByteString
-> [BuiltinByteString]
-> ContestationPeriod
-> CurrencySymbol
-> Bool
checkClose ScriptContext
ctx [Party]
parties BuiltinByteString
initialUtxoHash [BuiltinByteString]
signature ContestationPeriod
contestationPeriod CurrencySymbol
headId
    (Closed{[Party]
$sel:parties:Initial :: DatumType -> [Party]
parties :: [Party]
parties, $sel:snapshotNumber:Initial :: DatumType -> Integer
snapshotNumber = Integer
closedSnapshotNumber, POSIXTime
contestationDeadline :: POSIXTime
$sel:contestationDeadline:Initial :: DatumType -> POSIXTime
contestationDeadline, ContestationPeriod
$sel:contestationPeriod:Initial :: DatumType -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod, CurrencySymbol
$sel:headId:Initial :: DatumType -> CurrencySymbol
headId :: CurrencySymbol
headId, [PubKeyHash]
contesters :: [PubKeyHash]
$sel:contesters:Initial :: DatumType -> [PubKeyHash]
contesters}, Contest{[BuiltinByteString]
$sel:signature:CollectCom :: Input -> [BuiltinByteString]
signature :: [BuiltinByteString]
signature}) ->
      ScriptContext
-> POSIXTime
-> ContestationPeriod
-> [Party]
-> Integer
-> [BuiltinByteString]
-> [PubKeyHash]
-> CurrencySymbol
-> Bool
checkContest ScriptContext
ctx POSIXTime
contestationDeadline ContestationPeriod
contestationPeriod [Party]
parties Integer
closedSnapshotNumber [BuiltinByteString]
signature [PubKeyHash]
contesters CurrencySymbol
headId
    (Closed{[Party]
$sel:parties:Initial :: DatumType -> [Party]
parties :: [Party]
parties, BuiltinByteString
$sel:utxoHash:Initial :: DatumType -> BuiltinByteString
utxoHash :: BuiltinByteString
utxoHash, POSIXTime
$sel:contestationDeadline:Initial :: DatumType -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline, CurrencySymbol
$sel:headId:Initial :: DatumType -> CurrencySymbol
headId :: CurrencySymbol
headId}, Fanout{Integer
numberOfFanoutOutputs :: Integer
$sel:numberOfFanoutOutputs:CollectCom :: Input -> Integer
numberOfFanoutOutputs}) ->
      BuiltinByteString
-> POSIXTime
-> Integer
-> ScriptContext
-> CurrencySymbol
-> [Party]
-> Bool
checkFanout BuiltinByteString
utxoHash POSIXTime
contestationDeadline Integer
numberOfFanoutOutputs ScriptContext
ctx CurrencySymbol
headId [Party]
parties
    (DatumType, Input)
_ ->
      BuiltinString -> Bool
forall a. BuiltinString -> a
traceError $(errorCode InvalidHeadStateTransition)

-- | On-Chain verification for 'Abort' transition. It verifies that:
--
--   * All PTs have been burnt: The right number of Head tokens with the correct
--     head id are burnt, one PT for each party and a state token ST.
--
--   * All committed funds have been redistributed. This is done via v_commit
--     and it only needs to ensure that we have spent all comitted outputs,
--     which follows from burning all the PTs.
checkAbort ::
  ScriptContext ->
  CurrencySymbol ->
  [Party] ->
  Bool
checkAbort :: ScriptContext -> CurrencySymbol -> [Party] -> Bool
checkAbort ctx :: ScriptContext
ctx@ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo = TxInfo
txInfo} CurrencySymbol
headCurrencySymbol [Party]
parties =
  Value -> CurrencySymbol -> [Party] -> Bool
mustBurnAllHeadTokens Value
minted CurrencySymbol
headCurrencySymbol [Party]
parties
    Bool -> Bool -> Bool
&& ScriptContext -> CurrencySymbol -> Bool
mustBeSignedByParticipant ScriptContext
ctx CurrencySymbol
headCurrencySymbol
    Bool -> Bool -> Bool
&& Bool
mustReimburseCommittedUTxO
 where
  minted :: Value
minted = TxInfo -> Value
txInfoMint TxInfo
txInfo

  mustReimburseCommittedUTxO :: Bool
mustReimburseCommittedUTxO =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode ReimbursedOutputsDontMatch) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      BuiltinByteString
hashOfCommittedUTxO BuiltinByteString -> BuiltinByteString -> Bool
forall a. Eq a => a -> a -> Bool
== BuiltinByteString
hashOfOutputs

  hashOfOutputs :: BuiltinByteString
hashOfOutputs =
    -- NOTE: It is enough to just _take_ the same number of outputs that
    -- correspond to the number of commit inputs to make sure everything is
    -- reimbursed because we assume the outputs are correctly sorted with
    -- reimbursed commits coming first
    [TxOut] -> BuiltinByteString
hashTxOuts ([TxOut] -> BuiltinByteString) -> [TxOut] -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ Integer -> [TxOut] -> [TxOut]
forall a. Integer -> [a] -> [a]
take ([Commit] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [Commit]
committed) (TxInfo -> [TxOut]
txInfoOutputs TxInfo
txInfo)

  hashOfCommittedUTxO :: BuiltinByteString
hashOfCommittedUTxO =
    [Commit] -> BuiltinByteString
hashPreSerializedCommits [Commit]
committed

  committed :: [Commit]
committed = [Commit] -> [TxInInfo] -> [Commit]
committedUTxO [] (TxInfo -> [TxInInfo]
txInfoInputs TxInfo
txInfo)

  committedUTxO :: [Commit] -> [TxInInfo] -> [Commit]
committedUTxO [Commit]
commits = \case
    [] -> [Commit]
commits
    TxInInfo{txInInfoResolved :: TxInInfo -> TxOut
txInInfoResolved = TxOut
txOut} : [TxInInfo]
rest
      | CurrencySymbol -> TxOut -> Bool
hasPT CurrencySymbol
headCurrencySymbol TxOut
txOut ->
          [Commit] -> [TxInInfo] -> [Commit]
committedUTxO (TxOut -> [Commit]
commitDatum TxOut
txOut [Commit] -> [Commit] -> [Commit]
forall a. Semigroup a => a -> a -> a
<> [Commit]
commits) [TxInInfo]
rest
      | Bool
otherwise ->
          [Commit] -> [TxInInfo] -> [Commit]
committedUTxO [Commit]
commits [TxInInfo]
rest

-- | On-Chain verification for 'CollectCom' transition. It verifies that:
--
--   * All participants have committed (even empty commits)
--
--   * All commits are properly collected and locked into η as a hash
--     of serialized tx outputs in the same sequence as commit inputs!
--
--   * The transaction is performed (i.e. signed) by one of the head participants
--
--   * State token (ST) is present in the output
checkCollectCom ::
  -- | Script execution context
  ScriptContext ->
  (ContestationPeriod, [Party], CurrencySymbol) ->
  Bool
checkCollectCom :: ScriptContext
-> (ContestationPeriod, [Party], CurrencySymbol) -> Bool
checkCollectCom ctx :: ScriptContext
ctx@ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo = TxInfo
txInfo} (ContestationPeriod
contestationPeriod, [Party]
parties, CurrencySymbol
headId) =
  Bool
mustCollectUtxoHash
    Bool -> Bool -> Bool
&& Bool
mustNotChangeParameters
    Bool -> Bool -> Bool
&& Bool
mustCollectAllValue
    -- XXX: Is this really needed? If yes, why not check on the output?
    Bool -> Bool -> Bool
&& BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode STNotSpent) (CurrencySymbol -> Value -> Bool
hasST CurrencySymbol
headId Value
val)
    Bool -> Bool -> Bool
&& Bool
everyoneHasCommitted
    Bool -> Bool -> Bool
&& ScriptContext -> CurrencySymbol -> Bool
mustBeSignedByParticipant ScriptContext
ctx CurrencySymbol
headId
    Bool -> Bool -> Bool
&& TxInfo -> Bool
mustNotMintOrBurn TxInfo
txInfo
 where
  mustCollectUtxoHash :: Bool
mustCollectUtxoHash =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode IncorrectUtxoHash) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      BuiltinByteString
utxoHash BuiltinByteString -> BuiltinByteString -> Bool
forall a. Eq a => a -> a -> Bool
== [Commit] -> BuiltinByteString
hashPreSerializedCommits [Commit]
collectedCommits

  mustNotChangeParameters :: Bool
mustNotChangeParameters =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode ChangedParameters) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      [Party]
parties' [Party] -> [Party] -> Bool
forall a. Eq a => a -> a -> Bool
== [Party]
parties
        Bool -> Bool -> Bool
&& ContestationPeriod
contestationPeriod' ContestationPeriod -> ContestationPeriod -> Bool
forall a. Eq a => a -> a -> Bool
== ContestationPeriod
contestationPeriod
        Bool -> Bool -> Bool
&& CurrencySymbol
headId' CurrencySymbol -> CurrencySymbol -> Bool
forall a. Eq a => a -> a -> Bool
== CurrencySymbol
headId

  mustCollectAllValue :: Bool
mustCollectAllValue =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode NotAllValueCollected) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      -- NOTE: Instead of checking the head output val' against all collected
      -- value, we do ensure the output value is all non collected value - fees.
      -- This makes the script not scale badly with number of participants as it
      -- would commonly only be a small number of inputs/outputs to pay fees.
      Value
otherValueOut Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
notCollectedValueIn Value -> Value -> Value
forall a. AdditiveGroup a => a -> a -> a
- TxInfo -> Value
txInfoFee TxInfo
txInfo

  ([Party]
parties', BuiltinByteString
utxoHash, ContestationPeriod
contestationPeriod', CurrencySymbol
headId') =
    -- XXX: fromBuiltinData is super big (and also expensive?)
    case forall a. FromData a => BuiltinData -> Maybe a
fromBuiltinData @DatumType (BuiltinData -> Maybe DatumType) -> BuiltinData -> Maybe DatumType
forall a b. (a -> b) -> a -> b
$ Datum -> BuiltinData
getDatum (ScriptContext -> Datum
headOutputDatum ScriptContext
ctx) of
      Just
        Open
          { $sel:parties:Initial :: DatumType -> [Party]
parties = [Party]
p
          , $sel:utxoHash:Initial :: DatumType -> BuiltinByteString
utxoHash = BuiltinByteString
h
          , $sel:contestationPeriod:Initial :: DatumType -> ContestationPeriod
contestationPeriod = ContestationPeriod
cp
          , $sel:headId:Initial :: DatumType -> CurrencySymbol
headId = CurrencySymbol
hId
          } ->
          ([Party]
p, BuiltinByteString
h, ContestationPeriod
cp, CurrencySymbol
hId)
      Maybe DatumType
_ -> BuiltinString
-> ([Party], BuiltinByteString, ContestationPeriod, CurrencySymbol)
forall a. BuiltinString -> a
traceError $(errorCode WrongStateInOutputDatum)

  headAddress :: Address
headAddress = ScriptContext -> Address
getHeadAddress ScriptContext
ctx

  everyoneHasCommitted :: Bool
everyoneHasCommitted =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode MissingCommits) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      Integer
nTotalCommits Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== [Party] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [Party]
parties

  val :: Value
val = 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
ctx

  otherValueOut :: Value
otherValueOut =
    case TxInfo -> [TxOut]
txInfoOutputs TxInfo
txInfo of
      -- NOTE: First output must be head output
      (TxOut
_ : [TxOut]
rest) -> (TxOut -> Value) -> [TxOut] -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut -> Value
txOutValue [TxOut]
rest
      [TxOut]
_ -> Value
forall a. Monoid a => a
mempty

  -- NOTE: We do keep track of the value we do not want to collect as this is
  -- typically less, ideally only a single other input with only ADA in it.
  ([Commit]
collectedCommits, Integer
nTotalCommits, Value
notCollectedValueIn) =
    (TxInInfo
 -> ([Commit], Integer, Value) -> ([Commit], Integer, Value))
-> ([Commit], Integer, Value)
-> [TxInInfo]
-> ([Commit], Integer, Value)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      TxInInfo
-> ([Commit], Integer, Value) -> ([Commit], Integer, Value)
extractAndCountCommits
      ([], Integer
0, Value
forall a. Monoid a => a
mempty)
      (TxInfo -> [TxInInfo]
txInfoInputs TxInfo
txInfo)

  extractAndCountCommits :: TxInInfo
-> ([Commit], Integer, Value) -> ([Commit], Integer, Value)
extractAndCountCommits TxInInfo{TxOut
txInInfoResolved :: TxInInfo -> TxOut
txInInfoResolved :: TxOut
txInInfoResolved} ([Commit]
commits, Integer
nCommits, Value
notCollected)
    | TxOut -> Bool
isHeadOutput TxOut
txInInfoResolved =
        ([Commit]
commits, Integer
nCommits, Value
notCollected)
    | CurrencySymbol -> TxOut -> Bool
hasPT CurrencySymbol
headId TxOut
txInInfoResolved =
        (TxOut -> [Commit]
commitDatum TxOut
txInInfoResolved [Commit] -> [Commit] -> [Commit]
forall a. Semigroup a => a -> a -> a
<> [Commit]
commits, Integer -> Integer
forall a. Enum a => a -> a
succ Integer
nCommits, Value
notCollected)
    | Bool
otherwise =
        ([Commit]
commits, Integer
nCommits, Value
notCollected Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> TxOut -> Value
txOutValue TxOut
txInInfoResolved)

  isHeadOutput :: TxOut -> Bool
isHeadOutput TxOut
txOut = TxOut -> Address
txOutAddress TxOut
txOut Address -> Address -> Bool
forall a. Eq a => a -> a -> Bool
== Address
headAddress
{-# INLINEABLE checkCollectCom #-}

-- | Try to find the commit datum in the input and
-- if it is there return the committed utxo
commitDatum :: TxOut -> [Commit]
commitDatum :: TxOut -> [Commit]
commitDatum TxOut
input = do
  let datum :: Datum
datum = TxOut -> Datum
getTxOutDatum TxOut
input
  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
datum of
    Just (Party
_party, [Commit]
commits, CurrencySymbol
_headId) ->
      [Commit]
commits
    Maybe DatumType
Nothing -> []
{-# INLINEABLE commitDatum #-}

-- | The close validator must verify that:
--
--   * Check that the closing tx validity is bounded by contestation period
--
--   * Check that the deadline corresponds with tx validity and contestation period.
--
--   * The resulting utxo hash is correctly signed or the initial utxo hash,
--     depending on snapshot number
--
--   * The transaction is performed (i.e. signed) by one of the head participants
--
--   * State token (ST) is present in the output
--
--   * Contesters must be initialize as empty
--
--   * Value in v_head is preserved
checkClose ::
  ScriptContext ->
  [Party] ->
  BuiltinByteString ->
  [Signature] ->
  ContestationPeriod ->
  CurrencySymbol ->
  Bool
checkClose :: ScriptContext
-> [Party]
-> BuiltinByteString
-> [BuiltinByteString]
-> ContestationPeriod
-> CurrencySymbol
-> Bool
checkClose ScriptContext
ctx [Party]
parties BuiltinByteString
initialUtxoHash [BuiltinByteString]
sig ContestationPeriod
cperiod CurrencySymbol
headPolicyId =
  TxInfo -> Bool
mustNotMintOrBurn TxInfo
txInfo
    Bool -> Bool -> Bool
&& Bool
hasBoundedValidity
    Bool -> Bool -> Bool
&& Bool
checkDeadline
    Bool -> Bool -> Bool
&& Bool
checkSnapshot
    Bool -> Bool -> Bool
&& ScriptContext -> CurrencySymbol -> Bool
mustBeSignedByParticipant ScriptContext
ctx CurrencySymbol
headPolicyId
    Bool -> Bool -> Bool
&& Bool
mustInitializeContesters
    Bool -> Bool -> Bool
&& Bool
mustPreserveValue
    Bool -> Bool -> Bool
&& Bool
mustNotChangeParameters
 where
  mustPreserveValue :: Bool
mustPreserveValue =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode HeadValueIsNotPreserved) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      Value
val Value -> Value -> Bool
=== Value
val'

  val' :: Value
val' = TxOut -> Value
txOutValue (TxOut -> Value) -> ([TxOut] -> TxOut) -> [TxOut] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOut] -> TxOut
forall a. [a] -> a
head ([TxOut] -> Value) -> [TxOut] -> Value
forall a b. (a -> b) -> a -> b
$ TxInfo -> [TxOut]
txInfoOutputs TxInfo
txInfo

  val :: Value
val = 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
ctx

  hasBoundedValidity :: Bool
hasBoundedValidity =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode HasBoundedValidityCheckFailed) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      POSIXTime
tMax POSIXTime -> POSIXTime -> POSIXTime
forall a. AdditiveGroup a => a -> a -> a
- POSIXTime
tMin POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
<= POSIXTime
cp

  (Integer
closedSnapshotNumber, BuiltinByteString
closedUtxoHash, [Party]
parties', POSIXTime
closedContestationDeadline, ContestationPeriod
cperiod', CurrencySymbol
headId', [PubKeyHash]
contesters') =
    -- XXX: fromBuiltinData is super big (and also expensive?)
    case forall a. FromData a => BuiltinData -> Maybe a
fromBuiltinData @DatumType (BuiltinData -> Maybe DatumType) -> BuiltinData -> Maybe DatumType
forall a b. (a -> b) -> a -> b
$ Datum -> BuiltinData
getDatum (ScriptContext -> Datum
headOutputDatum ScriptContext
ctx) of
      Just
        Closed
          { Integer
$sel:snapshotNumber:Initial :: DatumType -> Integer
snapshotNumber :: Integer
snapshotNumber
          , BuiltinByteString
$sel:utxoHash:Initial :: DatumType -> BuiltinByteString
utxoHash :: BuiltinByteString
utxoHash
          , $sel:parties:Initial :: DatumType -> [Party]
parties = [Party]
p
          , POSIXTime
$sel:contestationDeadline:Initial :: DatumType -> POSIXTime
contestationDeadline :: POSIXTime
contestationDeadline
          , CurrencySymbol
$sel:headId:Initial :: DatumType -> CurrencySymbol
headId :: CurrencySymbol
headId
          , [PubKeyHash]
$sel:contesters:Initial :: DatumType -> [PubKeyHash]
contesters :: [PubKeyHash]
contesters
          , ContestationPeriod
$sel:contestationPeriod:Initial :: DatumType -> ContestationPeriod
contestationPeriod :: ContestationPeriod
contestationPeriod
          } -> (Integer
snapshotNumber, BuiltinByteString
utxoHash, [Party]
p, POSIXTime
contestationDeadline, ContestationPeriod
contestationPeriod, CurrencySymbol
headId, [PubKeyHash]
contesters)
      Maybe DatumType
_ -> BuiltinString
-> (Integer, BuiltinByteString, [Party], POSIXTime,
    ContestationPeriod, CurrencySymbol, [PubKeyHash])
forall a. BuiltinString -> a
traceError $(errorCode WrongStateInOutputDatum)

  checkSnapshot :: Bool
checkSnapshot
    | Integer
closedSnapshotNumber Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 =
        [Party]
-> CurrencySymbol
-> Integer
-> BuiltinByteString
-> [BuiltinByteString]
-> Bool
verifySnapshotSignature [Party]
parties CurrencySymbol
headPolicyId Integer
closedSnapshotNumber BuiltinByteString
closedUtxoHash [BuiltinByteString]
sig
    | Bool
otherwise =
        BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode ClosedWithNonInitialHash) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
          BuiltinByteString
closedUtxoHash BuiltinByteString -> BuiltinByteString -> Bool
forall a. Eq a => a -> a -> Bool
== BuiltinByteString
initialUtxoHash

  checkDeadline :: Bool
checkDeadline =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode IncorrectClosedContestationDeadline) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      POSIXTime
closedContestationDeadline POSIXTime -> POSIXTime -> Bool
forall a. Eq a => a -> a -> Bool
== ContestationPeriod -> ScriptContext -> POSIXTime
makeContestationDeadline ContestationPeriod
cperiod ScriptContext
ctx

  cp :: POSIXTime
cp = DiffMilliSeconds -> POSIXTime
fromMilliSeconds (ContestationPeriod -> DiffMilliSeconds
milliseconds ContestationPeriod
cperiod)

  tMax :: POSIXTime
tMax = case Interval POSIXTime -> UpperBound POSIXTime
forall a. Interval a -> UpperBound a
ivTo (Interval POSIXTime -> UpperBound POSIXTime)
-> Interval POSIXTime -> UpperBound POSIXTime
forall a b. (a -> b) -> a -> b
$ TxInfo -> Interval POSIXTime
txInfoValidRange TxInfo
txInfo of
    UpperBound (Finite POSIXTime
t) Bool
_ -> POSIXTime
t
    UpperBound POSIXTime
_InfiniteBound -> BuiltinString -> POSIXTime
forall a. BuiltinString -> a
traceError $(errorCode InfiniteUpperBound)

  tMin :: POSIXTime
tMin = case Interval POSIXTime -> LowerBound POSIXTime
forall a. Interval a -> LowerBound a
ivFrom (Interval POSIXTime -> LowerBound POSIXTime)
-> Interval POSIXTime -> LowerBound POSIXTime
forall a b. (a -> b) -> a -> b
$ TxInfo -> Interval POSIXTime
txInfoValidRange TxInfo
txInfo of
    LowerBound (Finite POSIXTime
t) Bool
_ -> POSIXTime
t
    LowerBound POSIXTime
_InfiniteBound -> BuiltinString -> POSIXTime
forall a. BuiltinString -> a
traceError $(errorCode InfiniteLowerBound)

  mustNotChangeParameters :: Bool
mustNotChangeParameters =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode ChangedParameters) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      CurrencySymbol
headId' CurrencySymbol -> CurrencySymbol -> Bool
forall a. Eq a => a -> a -> Bool
== CurrencySymbol
headPolicyId
        Bool -> Bool -> Bool
&& [Party]
parties' [Party] -> [Party] -> Bool
forall a. Eq a => a -> a -> Bool
== [Party]
parties
        Bool -> Bool -> Bool
&& ContestationPeriod
cperiod' ContestationPeriod -> ContestationPeriod -> Bool
forall a. Eq a => a -> a -> Bool
== ContestationPeriod
cperiod

  mustInitializeContesters :: Bool
mustInitializeContesters =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode ContestersNonEmpty) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      [PubKeyHash] -> Bool
forall a. [a] -> Bool
null [PubKeyHash]
contesters'

  ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo = TxInfo
txInfo} = ScriptContext
ctx
{-# INLINEABLE checkClose #-}

-- | The contest validator must verify that:
--
--   * The transaction does not mint or burn tokens.
--
--   * The contest snapshot number is strictly greater than the closed snapshot number.
--
--   * The contest snapshot is correctly signed.
--
--   * The transaction is performed (i.e. signed) by one of the head participants
--
--   * Party can contest only once.
--
--   * The transaction is performed before the deadline.
--
--   * Add signer to list of contesters.
--
--   * State token (ST) is present in the output
--
--   * Push deadline if signer is not the last one to contest.
--
--   * No other parameters have changed.
--
--   * Value in v_head is preserved
checkContest ::
  ScriptContext ->
  POSIXTime ->
  ContestationPeriod ->
  [Party] ->
  -- | Snapshot number of the closed state.
  SnapshotNumber ->
  [Signature] ->
  -- | Keys of party member which already contested.
  [PubKeyHash] ->
  -- | Head id
  CurrencySymbol ->
  Bool
checkContest :: ScriptContext
-> POSIXTime
-> ContestationPeriod
-> [Party]
-> Integer
-> [BuiltinByteString]
-> [PubKeyHash]
-> CurrencySymbol
-> Bool
checkContest ScriptContext
ctx POSIXTime
contestationDeadline ContestationPeriod
contestationPeriod [Party]
parties Integer
closedSnapshotNumber [BuiltinByteString]
sig [PubKeyHash]
contesters CurrencySymbol
headId =
  TxInfo -> Bool
mustNotMintOrBurn TxInfo
txInfo
    Bool -> Bool -> Bool
&& Bool
mustBeNewer
    Bool -> Bool -> Bool
&& Bool
mustBeMultiSigned
    Bool -> Bool -> Bool
&& ScriptContext -> CurrencySymbol -> Bool
mustBeSignedByParticipant ScriptContext
ctx CurrencySymbol
headId
    Bool -> Bool -> Bool
&& Bool
checkSignedParticipantContestOnlyOnce
    Bool -> Bool -> Bool
&& Bool
mustBeWithinContestationPeriod
    Bool -> Bool -> Bool
&& Bool
mustUpdateContesters
    Bool -> Bool -> Bool
&& Bool
mustPushDeadline
    Bool -> Bool -> Bool
&& Bool
mustNotChangeParameters
    Bool -> Bool -> Bool
&& Bool
mustPreserveValue
 where
  mustPreserveValue :: Bool
mustPreserveValue =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode HeadValueIsNotPreserved) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      Value
val Value -> Value -> Bool
=== Value
val'

  val' :: Value
val' = TxOut -> Value
txOutValue (TxOut -> Value) -> ([TxOut] -> TxOut) -> [TxOut] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TxOut] -> TxOut
forall a. [a] -> a
head ([TxOut] -> Value) -> [TxOut] -> Value
forall a b. (a -> b) -> a -> b
$ TxInfo -> [TxOut]
txInfoOutputs TxInfo
txInfo

  val :: Value
val = 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
ctx

  mustBeNewer :: Bool
mustBeNewer =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode TooOldSnapshot) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      Integer
contestSnapshotNumber Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
closedSnapshotNumber

  mustBeMultiSigned :: Bool
mustBeMultiSigned =
    [Party]
-> CurrencySymbol
-> Integer
-> BuiltinByteString
-> [BuiltinByteString]
-> Bool
verifySnapshotSignature [Party]
parties CurrencySymbol
headId Integer
contestSnapshotNumber BuiltinByteString
contestUtxoHash [BuiltinByteString]
sig

  mustBeWithinContestationPeriod :: Bool
mustBeWithinContestationPeriod =
    case Interval POSIXTime -> UpperBound POSIXTime
forall a. Interval a -> UpperBound a
ivTo (TxInfo -> Interval POSIXTime
txInfoValidRange TxInfo
txInfo) of
      UpperBound (Finite POSIXTime
time) Bool
_ ->
        BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode UpperBoundBeyondContestationDeadline) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
          POSIXTime
time POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
<= POSIXTime
contestationDeadline
      UpperBound POSIXTime
_ -> BuiltinString -> Bool
forall a. BuiltinString -> a
traceError $(errorCode ContestNoUpperBoundDefined)

  mustNotChangeParameters :: Bool
mustNotChangeParameters =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode ChangedParameters) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      [Party]
parties' [Party] -> [Party] -> Bool
forall a. Eq a => a -> a -> Bool
== [Party]
parties
        Bool -> Bool -> Bool
&& CurrencySymbol
headId' CurrencySymbol -> CurrencySymbol -> Bool
forall a. Eq a => a -> a -> Bool
== CurrencySymbol
headId
        Bool -> Bool -> Bool
&& ContestationPeriod
contestationPeriod' ContestationPeriod -> ContestationPeriod -> Bool
forall a. Eq a => a -> a -> Bool
== ContestationPeriod
contestationPeriod

  mustPushDeadline :: Bool
mustPushDeadline =
    if [PubKeyHash] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [PubKeyHash]
contesters' Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== [Party] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [Party]
parties'
      then
        BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode MustNotPushDeadline) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
          POSIXTime
contestationDeadline' POSIXTime -> POSIXTime -> Bool
forall a. Eq a => a -> a -> Bool
== POSIXTime
contestationDeadline
      else
        BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode MustPushDeadline) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
          POSIXTime
contestationDeadline' POSIXTime -> POSIXTime -> Bool
forall a. Eq a => a -> a -> Bool
== POSIXTime -> ContestationPeriod -> POSIXTime
addContestationPeriod POSIXTime
contestationDeadline ContestationPeriod
contestationPeriod

  mustUpdateContesters :: Bool
mustUpdateContesters =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode ContesterNotIncluded) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      [PubKeyHash]
contesters' [PubKeyHash] -> [PubKeyHash] -> Bool
forall a. Eq a => a -> a -> Bool
== PubKeyHash
contester PubKeyHash -> [PubKeyHash] -> [PubKeyHash]
forall a. a -> [a] -> [a]
: [PubKeyHash]
contesters

  (Integer
contestSnapshotNumber, BuiltinByteString
contestUtxoHash, [Party]
parties', POSIXTime
contestationDeadline', ContestationPeriod
contestationPeriod', CurrencySymbol
headId', [PubKeyHash]
contesters') =
    -- XXX: fromBuiltinData is super big (and also expensive?)
    case forall a. FromData a => BuiltinData -> Maybe a
fromBuiltinData @DatumType (BuiltinData -> Maybe DatumType) -> BuiltinData -> Maybe DatumType
forall a b. (a -> b) -> a -> b
$ Datum -> BuiltinData
getDatum (ScriptContext -> Datum
headOutputDatum ScriptContext
ctx) of
      Just
        Closed
          { Integer
$sel:snapshotNumber:Initial :: DatumType -> Integer
snapshotNumber :: Integer
snapshotNumber
          , BuiltinByteString
$sel:utxoHash:Initial :: DatumType -> BuiltinByteString
utxoHash :: BuiltinByteString
utxoHash
          , $sel:parties:Initial :: DatumType -> [Party]
parties = [Party]
p
          , $sel:contestationDeadline:Initial :: DatumType -> POSIXTime
contestationDeadline = POSIXTime
dl
          , $sel:contestationPeriod:Initial :: DatumType -> ContestationPeriod
contestationPeriod = ContestationPeriod
cp
          , $sel:headId:Initial :: DatumType -> CurrencySymbol
headId = CurrencySymbol
hid
          , $sel:contesters:Initial :: DatumType -> [PubKeyHash]
contesters = [PubKeyHash]
cs
          } -> (Integer
snapshotNumber, BuiltinByteString
utxoHash, [Party]
p, POSIXTime
dl, ContestationPeriod
cp, CurrencySymbol
hid, [PubKeyHash]
cs)
      Maybe DatumType
_ -> BuiltinString
-> (Integer, BuiltinByteString, [Party], POSIXTime,
    ContestationPeriod, CurrencySymbol, [PubKeyHash])
forall a. BuiltinString -> a
traceError $(errorCode WrongStateInOutputDatum)

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

  contester :: PubKeyHash
contester =
    case TxInfo -> [PubKeyHash]
txInfoSignatories TxInfo
txInfo of
      [PubKeyHash
signer] -> PubKeyHash
signer
      [PubKeyHash]
_ -> BuiltinString -> PubKeyHash
forall a. BuiltinString -> a
traceError $(errorCode WrongNumberOfSigners)

  checkSignedParticipantContestOnlyOnce :: Bool
checkSignedParticipantContestOnlyOnce =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode SignerAlreadyContested) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      PubKeyHash
contester PubKeyHash -> [PubKeyHash] -> Bool
forall a. Eq a => a -> [a] -> Bool
`notElem` [PubKeyHash]
contesters
{-# INLINEABLE checkContest #-}

checkFanout ::
  BuiltinByteString ->
  POSIXTime ->
  Integer ->
  ScriptContext ->
  CurrencySymbol ->
  [Party] ->
  Bool
checkFanout :: BuiltinByteString
-> POSIXTime
-> Integer
-> ScriptContext
-> CurrencySymbol
-> [Party]
-> Bool
checkFanout BuiltinByteString
utxoHash POSIXTime
contestationDeadline Integer
numberOfFanoutOutputs ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo = TxInfo
txInfo} CurrencySymbol
currencySymbol [Party]
parties =
  Value -> CurrencySymbol -> [Party] -> Bool
mustBurnAllHeadTokens Value
minted CurrencySymbol
currencySymbol [Party]
parties
    Bool -> Bool -> Bool
&& Bool
hasSameUTxOHash
    Bool -> Bool -> Bool
&& Bool
afterContestationDeadline
 where
  minted :: Value
minted = TxInfo -> Value
txInfoMint TxInfo
txInfo

  hasSameUTxOHash :: Bool
hasSameUTxOHash =
    BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode FannedOutUtxoHashNotEqualToClosedUtxoHash) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      BuiltinByteString
fannedOutUtxoHash BuiltinByteString -> BuiltinByteString -> Bool
forall a. Eq a => a -> a -> Bool
== BuiltinByteString
utxoHash

  fannedOutUtxoHash :: BuiltinByteString
fannedOutUtxoHash = [TxOut] -> BuiltinByteString
hashTxOuts ([TxOut] -> BuiltinByteString) -> [TxOut] -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$ Integer -> [TxOut] -> [TxOut]
forall a. Integer -> [a] -> [a]
take Integer
numberOfFanoutOutputs [TxOut]
txInfoOutputs

  TxInfo{[TxOut]
txInfoOutputs :: TxInfo -> [TxOut]
txInfoOutputs :: [TxOut]
txInfoOutputs} = TxInfo
txInfo

  afterContestationDeadline :: Bool
afterContestationDeadline =
    case Interval POSIXTime -> LowerBound POSIXTime
forall a. Interval a -> LowerBound a
ivFrom (TxInfo -> Interval POSIXTime
txInfoValidRange TxInfo
txInfo) of
      LowerBound (Finite POSIXTime
time) Bool
_ ->
        BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode LowerBoundBeforeContestationDeadline) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
          POSIXTime
time POSIXTime -> POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
> POSIXTime
contestationDeadline
      LowerBound POSIXTime
_ -> BuiltinString -> Bool
forall a. BuiltinString -> a
traceError $(errorCode FanoutNoLowerBoundDefined)
{-# INLINEABLE checkFanout #-}

--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

(&) :: a -> (a -> b) -> b
& :: forall a b. a -> (a -> b) -> b
(&) = ((a -> b) -> a -> b) -> a -> (a -> b) -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)
{-# INLINEABLE (&) #-}

txOutAdaValue :: TxOut -> Integer
txOutAdaValue :: TxOut -> Integer
txOutAdaValue TxOut
o = Value -> CurrencySymbol -> TokenName -> Integer
valueOf (TxOut -> Value
txOutValue TxOut
o) CurrencySymbol
adaSymbol TokenName
adaToken
{-# INLINEABLE txOutAdaValue #-}

txInfoAdaFee :: TxInfo -> Integer
txInfoAdaFee :: TxInfo -> Integer
txInfoAdaFee TxInfo
tx = Value -> CurrencySymbol -> TokenName -> Integer
valueOf (TxInfo -> Value
txInfoFee TxInfo
tx) CurrencySymbol
adaSymbol TokenName
adaToken
{-# INLINEABLE txInfoAdaFee #-}

makeContestationDeadline :: ContestationPeriod -> ScriptContext -> POSIXTime
makeContestationDeadline :: ContestationPeriod -> ScriptContext -> POSIXTime
makeContestationDeadline ContestationPeriod
cperiod ScriptContext{TxInfo
scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo :: TxInfo
scriptContextTxInfo} =
  case Interval POSIXTime -> UpperBound POSIXTime
forall a. Interval a -> UpperBound a
ivTo (TxInfo -> Interval POSIXTime
txInfoValidRange TxInfo
scriptContextTxInfo) of
    UpperBound (Finite POSIXTime
time) Bool
_ -> POSIXTime -> ContestationPeriod -> POSIXTime
addContestationPeriod POSIXTime
time ContestationPeriod
cperiod
    UpperBound POSIXTime
_ -> BuiltinString -> POSIXTime
forall a. BuiltinString -> a
traceError $(errorCode CloseNoUpperBoundDefined)
{-# INLINEABLE makeContestationDeadline #-}

getHeadInput :: ScriptContext -> TxInInfo
getHeadInput :: ScriptContext -> TxInInfo
getHeadInput ScriptContext
ctx = case ScriptContext -> Maybe TxInInfo
findOwnInput ScriptContext
ctx of
  Maybe TxInInfo
Nothing -> BuiltinString -> TxInInfo
forall a. BuiltinString -> a
traceError $(errorCode ScriptNotSpendingAHeadInput)
  Just TxInInfo
x -> TxInInfo
x
{-# INLINEABLE getHeadInput #-}

getHeadAddress :: ScriptContext -> Address
getHeadAddress :: ScriptContext -> Address
getHeadAddress = TxOut -> Address
txOutAddress (TxOut -> Address)
-> (ScriptContext -> TxOut) -> ScriptContext -> Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxInInfo -> TxOut
txInInfoResolved (TxInInfo -> TxOut)
-> (ScriptContext -> TxInInfo) -> ScriptContext -> TxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptContext -> TxInInfo
getHeadInput
{-# INLINEABLE getHeadAddress #-}

-- XXX: We might not need to distinguish between the three cases here.
mustBeSignedByParticipant ::
  ScriptContext ->
  CurrencySymbol ->
  Bool
mustBeSignedByParticipant :: ScriptContext -> CurrencySymbol -> Bool
mustBeSignedByParticipant ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo = TxInfo
txInfo} CurrencySymbol
headCurrencySymbol =
  case PubKeyHash -> BuiltinByteString
getPubKeyHash (PubKeyHash -> BuiltinByteString)
-> [PubKeyHash] -> [BuiltinByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxInfo -> [PubKeyHash]
txInfoSignatories TxInfo
txInfo of
    [BuiltinByteString
signer] ->
      BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode SignerIsNotAParticipant) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
        BuiltinByteString
signer BuiltinByteString -> [BuiltinByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
`elem` (TokenName -> BuiltinByteString
unTokenName (TokenName -> BuiltinByteString)
-> [TokenName] -> [BuiltinByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TokenName]
participationTokens)
    [] ->
      BuiltinString -> Bool
forall a. BuiltinString -> a
traceError $(errorCode NoSigners)
    [BuiltinByteString]
_ ->
      BuiltinString -> Bool
forall a. BuiltinString -> a
traceError $(errorCode TooManySigners)
 where
  participationTokens :: [TokenName]
participationTokens = [TxInInfo] -> [TokenName]
loop (TxInfo -> [TxInInfo]
txInfoInputs TxInfo
txInfo)
  loop :: [TxInInfo] -> [TokenName]
loop = \case
    [] -> []
    (TxInInfo{TxOut
txInInfoResolved :: TxInInfo -> TxOut
txInInfoResolved :: TxOut
txInInfoResolved} : [TxInInfo]
rest) ->
      CurrencySymbol -> Value -> [TokenName]
findParticipationTokens CurrencySymbol
headCurrencySymbol (TxOut -> Value
txOutValue TxOut
txInInfoResolved) [TokenName] -> [TokenName] -> [TokenName]
forall a. [a] -> [a] -> [a]
++ [TxInInfo] -> [TokenName]
loop [TxInInfo]
rest
{-# INLINEABLE mustBeSignedByParticipant #-}

findParticipationTokens :: CurrencySymbol -> Value -> [TokenName]
findParticipationTokens :: CurrencySymbol -> Value -> [TokenName]
findParticipationTokens CurrencySymbol
headCurrency (Value Map CurrencySymbol (Map TokenName Integer)
val) =
  case Map TokenName Integer -> [(TokenName, Integer)]
forall k v. Map k v -> [(k, v)]
AssocMap.toList (Map TokenName Integer -> [(TokenName, Integer)])
-> Maybe (Map TokenName Integer) -> Maybe [(TokenName, Integer)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CurrencySymbol
-> Map CurrencySymbol (Map TokenName Integer)
-> Maybe (Map TokenName Integer)
forall k v. Eq k => k -> Map k v -> Maybe v
AssocMap.lookup CurrencySymbol
headCurrency Map CurrencySymbol (Map TokenName Integer)
val of
    Just [(TokenName, Integer)]
tokens ->
      ((TokenName, Integer) -> Maybe TokenName)
-> [(TokenName, Integer)] -> [TokenName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(TokenName
tokenName, Integer
n) -> if Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 then TokenName -> Maybe TokenName
forall a. a -> Maybe a
Just TokenName
tokenName else Maybe TokenName
forall a. Maybe a
Nothing) [(TokenName, Integer)]
tokens
    Maybe [(TokenName, Integer)]
_ ->
      []
{-# INLINEABLE findParticipationTokens #-}

headOutputDatum :: ScriptContext -> Datum
headOutputDatum :: ScriptContext -> Datum
headOutputDatum ScriptContext
ctx =
  case TxInfo -> [TxOut]
txInfoOutputs TxInfo
txInfo of
    (TxOut
o : [TxOut]
_)
      | TxOut -> Address
txOutAddress TxOut
o Address -> Address -> Bool
forall a. Eq a => a -> a -> Bool
== Address
headAddress -> TxOut -> Datum
getTxOutDatum TxOut
o
    [TxOut]
_ -> BuiltinString -> Datum
forall a. BuiltinString -> a
traceError $(errorCode NotPayingToHead)
 where
  headAddress :: Address
headAddress = ScriptContext -> Address
getHeadAddress ScriptContext
ctx

  ScriptContext{scriptContextTxInfo :: ScriptContext -> TxInfo
scriptContextTxInfo = TxInfo
txInfo} = ScriptContext
ctx
{-# INLINEABLE headOutputDatum #-}

getTxOutDatum :: TxOut -> Datum
getTxOutDatum :: TxOut -> Datum
getTxOutDatum TxOut
o =
  case TxOut -> OutputDatum
txOutDatum TxOut
o of
    OutputDatum
NoOutputDatum -> BuiltinString -> Datum
forall a. BuiltinString -> a
traceError $(errorCode NoOutputDatumError)
    OutputDatumHash DatumHash
_dh -> BuiltinString -> Datum
forall a. BuiltinString -> a
traceError $(errorCode UnexpectedNonInlineDatum)
    OutputDatum Datum
d -> Datum
d
{-# INLINEABLE getTxOutDatum #-}

-- | Hash a potentially unordered list of commits by sorting them, concatenating
-- their 'preSerializedOutput' bytes and creating a SHA2_256 digest over that.
--
-- NOTE: See note from `hashTxOuts`.
hashPreSerializedCommits :: [Commit] -> BuiltinByteString
hashPreSerializedCommits :: [Commit] -> BuiltinByteString
hashPreSerializedCommits [Commit]
commits =
  BuiltinByteString -> BuiltinByteString
sha2_256 (BuiltinByteString -> BuiltinByteString)
-> ([Commit] -> BuiltinByteString) -> [Commit] -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Commit -> BuiltinByteString) -> [Commit] -> BuiltinByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Commit -> BuiltinByteString
preSerializedOutput ([Commit] -> BuiltinByteString) -> [Commit] -> BuiltinByteString
forall a b. (a -> b) -> a -> b
$
    (Commit -> Commit -> Ordering) -> [Commit] -> [Commit]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\Commit
a Commit
b -> TxOutRef -> TxOutRef -> Ordering
compareRef (Commit -> TxOutRef
input Commit
a) (Commit -> TxOutRef
input Commit
b)) [Commit]
commits
{-# INLINEABLE hashPreSerializedCommits #-}

-- | Hash a pre-ordered list of transaction outputs by serializing each
-- individual 'TxOut', concatenating all bytes together and creating a SHA2_256
-- digest over that.
--
-- NOTE: In general, from asserting that `hash(x || y) = hash (x' || y')` it is
-- not safe to conclude that `(x,y) = (x', y')` as the same hash could be
-- obtained by moving one or more bytes from the end of `x` to the beginning of
-- `y`, but in the context of Hydra validators it seems impossible to exploit
-- this property without breaking other logic or verification (eg. producing a
-- valid and meaningful `TxOut`).
hashTxOuts :: [TxOut] -> BuiltinByteString
hashTxOuts :: [TxOut] -> BuiltinByteString
hashTxOuts =
  BuiltinByteString -> BuiltinByteString
sha2_256 (BuiltinByteString -> BuiltinByteString)
-> ([TxOut] -> BuiltinByteString) -> [TxOut] -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut -> BuiltinByteString) -> [TxOut] -> BuiltinByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (BuiltinData -> BuiltinByteString
Builtins.serialiseData (BuiltinData -> BuiltinByteString)
-> (TxOut -> BuiltinData) -> TxOut -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData)
{-# INLINEABLE hashTxOuts #-}

-- | Check if 'TxOut' contains the PT token.
hasPT :: CurrencySymbol -> TxOut -> Bool
hasPT :: CurrencySymbol -> TxOut -> Bool
hasPT CurrencySymbol
headCurrencySymbol TxOut
txOut =
  let pts :: [TokenName]
pts = CurrencySymbol -> Value -> [TokenName]
findParticipationTokens CurrencySymbol
headCurrencySymbol (TxOut -> Value
txOutValue TxOut
txOut)
   in [TokenName] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [TokenName]
pts Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1
{-# INLINEABLE hasPT #-}

verifySnapshotSignature :: [Party] -> CurrencySymbol -> SnapshotNumber -> BuiltinByteString -> [Signature] -> Bool
verifySnapshotSignature :: [Party]
-> CurrencySymbol
-> Integer
-> BuiltinByteString
-> [BuiltinByteString]
-> Bool
verifySnapshotSignature [Party]
parties CurrencySymbol
headId Integer
snapshotNumber BuiltinByteString
utxoHash [BuiltinByteString]
sigs =
  BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode SignatureVerificationFailed) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    [Party] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [Party]
parties
      Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== [BuiltinByteString] -> Integer
forall (t :: * -> *) a. Foldable t => t a -> Integer
length [BuiltinByteString]
sigs
      Bool -> Bool -> Bool
&& ((Party, BuiltinByteString) -> Bool)
-> [(Party, BuiltinByteString)] -> Bool
forall a. (a -> Bool) -> [a] -> Bool
all ((Party -> BuiltinByteString -> Bool)
-> (Party, BuiltinByteString) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Party -> BuiltinByteString -> Bool)
 -> (Party, BuiltinByteString) -> Bool)
-> (Party -> BuiltinByteString -> Bool)
-> (Party, BuiltinByteString)
-> Bool
forall a b. (a -> b) -> a -> b
$ CurrencySymbol
-> Integer
-> BuiltinByteString
-> Party
-> BuiltinByteString
-> Bool
verifyPartySignature CurrencySymbol
headId Integer
snapshotNumber BuiltinByteString
utxoHash) ([Party] -> [BuiltinByteString] -> [(Party, BuiltinByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Party]
parties [BuiltinByteString]
sigs)
{-# INLINEABLE verifySnapshotSignature #-}

verifyPartySignature :: CurrencySymbol -> SnapshotNumber -> BuiltinByteString -> Party -> Signature -> Bool
verifyPartySignature :: CurrencySymbol
-> Integer
-> BuiltinByteString
-> Party
-> BuiltinByteString
-> Bool
verifyPartySignature CurrencySymbol
headId Integer
snapshotNumber BuiltinByteString
utxoHash Party
party BuiltinByteString
signed =
  BuiltinString -> Bool -> Bool
traceIfFalse $(errorCode PartySignatureVerificationFailed) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> Bool
verifyEd25519Signature (Party -> BuiltinByteString
vkey Party
party) BuiltinByteString
message BuiltinByteString
signed
 where
  message :: BuiltinByteString
message =
    -- TODO: document CDDL format, either here or in 'Hydra.Snapshot.getSignableRepresentation'
    BuiltinData -> BuiltinByteString
Builtins.serialiseData (CurrencySymbol -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData CurrencySymbol
headId)
      BuiltinByteString -> BuiltinByteString -> BuiltinByteString
forall a. Semigroup a => a -> a -> a
<> BuiltinData -> BuiltinByteString
Builtins.serialiseData (Integer -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData Integer
snapshotNumber)
      BuiltinByteString -> BuiltinByteString -> BuiltinByteString
forall a. Semigroup a => a -> a -> a
<> BuiltinData -> BuiltinByteString
Builtins.serialiseData (BuiltinByteString -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData BuiltinByteString
utxoHash)
{-# INLINEABLE verifyPartySignature #-}

compareRef :: TxOutRef -> TxOutRef -> Ordering
TxOutRef{TxId
txOutRefId :: TxId
txOutRefId :: TxOutRef -> TxId
txOutRefId, Integer
txOutRefIdx :: Integer
txOutRefIdx :: TxOutRef -> Integer
txOutRefIdx} compareRef :: TxOutRef -> TxOutRef -> Ordering
`compareRef` TxOutRef{txOutRefId :: TxOutRef -> TxId
txOutRefId = TxId
id', txOutRefIdx :: TxOutRef -> Integer
txOutRefIdx = Integer
idx'} =
  case TxId -> TxId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare TxId
txOutRefId TxId
id' of
    Ordering
EQ -> Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Integer
txOutRefIdx Integer
idx'
    Ordering
ord -> Ordering
ord
{-# INLINEABLE compareRef #-}

compiledValidator :: CompiledCode ValidatorType
compiledValidator :: CompiledCode ValidatorType
compiledValidator =
  $$(PlutusTx.compile [||wrap headValidator||])
 where
  wrap :: (DatumType -> Input -> ScriptContext -> Bool) -> ValidatorType
wrap = forall datum redeemer context.
(UnsafeFromData datum, UnsafeFromData redeemer,
 UnsafeFromData context) =>
(datum -> redeemer -> context -> 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 PlutusScriptV2
-> SerialisedScript -> ScriptHash
forall lang.
PlutusScriptVersion lang -> SerialisedScript -> ScriptHash
scriptValidatorHash PlutusScriptVersion PlutusScriptV2
PlutusScriptV2 SerialisedScript
validatorScript