module Hydra.Tx.Contest where

import Hydra.Cardano.Api
import Hydra.Prelude

import Hydra.Contract.Head qualified as Head
import Hydra.Contract.HeadState qualified as Head
import Hydra.Data.ContestationPeriod (addContestationPeriod)
import Hydra.Data.Party qualified as OnChain
import Hydra.Ledger.Cardano.Builder (
  addExtraRequiredSigners,
  addInputs,
  addOutputs,
  addReferenceInputs,
  emptyTxBody,
  setValidityUpperBound,
  unsafeBuildTransaction,
 )
import Hydra.Plutus.Orphans ()
import Hydra.Tx.ContestationPeriod (ContestationPeriod, toChain)
import Hydra.Tx.Crypto (MultiSignature (..), toPlutusSignatures)
import Hydra.Tx.HeadId (HeadId, headIdToCurrencySymbol)
import Hydra.Tx.IsTx (hashUTxO)
import Hydra.Tx.ScriptRegistry (ScriptRegistry, headReference)
import Hydra.Tx.Snapshot (Snapshot (..), SnapshotVersion)
import Hydra.Tx.Utils (mkHydraHeadV1TxName)
import PlutusLedgerApi.V2 (toBuiltin)
import PlutusLedgerApi.V2 qualified as Plutus

type PointInTime = (SlotNo, UTCTime)

data ClosedThreadOutput = ClosedThreadOutput
  { ClosedThreadOutput -> (TxIn, TxOut CtxUTxO)
closedThreadUTxO :: (TxIn, TxOut CtxUTxO)
  , ClosedThreadOutput -> [Party]
closedParties :: [OnChain.Party]
  , ClosedThreadOutput -> POSIXTime
closedContestationDeadline :: Plutus.POSIXTime
  , ClosedThreadOutput -> [PubKeyHash]
closedContesters :: [Plutus.PubKeyHash]
  }
  deriving stock (ClosedThreadOutput -> ClosedThreadOutput -> Bool
(ClosedThreadOutput -> ClosedThreadOutput -> Bool)
-> (ClosedThreadOutput -> ClosedThreadOutput -> Bool)
-> Eq ClosedThreadOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClosedThreadOutput -> ClosedThreadOutput -> Bool
== :: ClosedThreadOutput -> ClosedThreadOutput -> Bool
$c/= :: ClosedThreadOutput -> ClosedThreadOutput -> Bool
/= :: ClosedThreadOutput -> ClosedThreadOutput -> Bool
Eq, Int -> ClosedThreadOutput -> ShowS
[ClosedThreadOutput] -> ShowS
ClosedThreadOutput -> String
(Int -> ClosedThreadOutput -> ShowS)
-> (ClosedThreadOutput -> String)
-> ([ClosedThreadOutput] -> ShowS)
-> Show ClosedThreadOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClosedThreadOutput -> ShowS
showsPrec :: Int -> ClosedThreadOutput -> ShowS
$cshow :: ClosedThreadOutput -> String
show :: ClosedThreadOutput -> String
$cshowList :: [ClosedThreadOutput] -> ShowS
showList :: [ClosedThreadOutput] -> ShowS
Show, (forall x. ClosedThreadOutput -> Rep ClosedThreadOutput x)
-> (forall x. Rep ClosedThreadOutput x -> ClosedThreadOutput)
-> Generic ClosedThreadOutput
forall x. Rep ClosedThreadOutput x -> ClosedThreadOutput
forall x. ClosedThreadOutput -> Rep ClosedThreadOutput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ClosedThreadOutput -> Rep ClosedThreadOutput x
from :: forall x. ClosedThreadOutput -> Rep ClosedThreadOutput x
$cto :: forall x. Rep ClosedThreadOutput x -> ClosedThreadOutput
to :: forall x. Rep ClosedThreadOutput x -> ClosedThreadOutput
Generic)
  deriving anyclass ([ClosedThreadOutput] -> Value
[ClosedThreadOutput] -> Encoding
ClosedThreadOutput -> Bool
ClosedThreadOutput -> Value
ClosedThreadOutput -> Encoding
(ClosedThreadOutput -> Value)
-> (ClosedThreadOutput -> Encoding)
-> ([ClosedThreadOutput] -> Value)
-> ([ClosedThreadOutput] -> Encoding)
-> (ClosedThreadOutput -> Bool)
-> ToJSON ClosedThreadOutput
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ClosedThreadOutput -> Value
toJSON :: ClosedThreadOutput -> Value
$ctoEncoding :: ClosedThreadOutput -> Encoding
toEncoding :: ClosedThreadOutput -> Encoding
$ctoJSONList :: [ClosedThreadOutput] -> Value
toJSONList :: [ClosedThreadOutput] -> Value
$ctoEncodingList :: [ClosedThreadOutput] -> Encoding
toEncodingList :: [ClosedThreadOutput] -> Encoding
$comitField :: ClosedThreadOutput -> Bool
omitField :: ClosedThreadOutput -> Bool
ToJSON, Maybe ClosedThreadOutput
Value -> Parser [ClosedThreadOutput]
Value -> Parser ClosedThreadOutput
(Value -> Parser ClosedThreadOutput)
-> (Value -> Parser [ClosedThreadOutput])
-> Maybe ClosedThreadOutput
-> FromJSON ClosedThreadOutput
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ClosedThreadOutput
parseJSON :: Value -> Parser ClosedThreadOutput
$cparseJSONList :: Value -> Parser [ClosedThreadOutput]
parseJSONList :: Value -> Parser [ClosedThreadOutput]
$comittedField :: Maybe ClosedThreadOutput
omittedField :: Maybe ClosedThreadOutput
FromJSON)

-- XXX: This function is VERY similar to the 'closeTx' function (only notable
-- difference being the redeemer, which is in itself also the same structure as
-- the close's one. We could potentially refactor this to avoid repetition or do
-- something more principled at the protocol level itself and "merge" close and
-- contest as one operation.
contestTx ::
  -- | Published Hydra scripts to reference.
  ScriptRegistry ->
  -- | Party who's authorizing this transaction
  VerificationKey PaymentKey ->
  HeadId ->
  ContestationPeriod ->
  SnapshotVersion ->
  -- | Contested snapshot number (i.e. the one we contest to)
  Snapshot Tx ->
  -- | Multi-signature of the whole snapshot
  MultiSignature (Snapshot Tx) ->
  -- | Current slot and posix time to be used as the contestation time.
  PointInTime ->
  -- | Everything needed to spend the Head state-machine output.
  ClosedThreadOutput ->
  Tx
contestTx :: ScriptRegistry
-> VerificationKey PaymentKey
-> HeadId
-> ContestationPeriod
-> SnapshotVersion
-> Snapshot Tx
-> MultiSignature (Snapshot Tx)
-> PointInTime
-> ClosedThreadOutput
-> Tx
contestTx ScriptRegistry
scriptRegistry VerificationKey PaymentKey
vk HeadId
headId ContestationPeriod
contestationPeriod SnapshotVersion
openVersion Snapshot{SnapshotNumber
number :: SnapshotNumber
$sel:number:Snapshot :: forall tx. Snapshot tx -> SnapshotNumber
number, UTxOType Tx
utxo :: UTxOType Tx
$sel:utxo:Snapshot :: forall tx. Snapshot tx -> UTxOType tx
utxo, Maybe (UTxOType Tx)
utxoToDecommit :: Maybe (UTxOType Tx)
$sel:utxoToDecommit:Snapshot :: forall tx. Snapshot tx -> Maybe (UTxOType tx)
utxoToDecommit, SnapshotVersion
version :: SnapshotVersion
$sel:version:Snapshot :: forall tx. Snapshot tx -> SnapshotVersion
version} MultiSignature (Snapshot Tx)
sig (SlotNo
slotNo, UTCTime
_) ClosedThreadOutput
closedThreadOutput =
  HasCallStack => TxBodyContent BuildTx -> Tx
TxBodyContent BuildTx -> Tx
unsafeBuildTransaction (TxBodyContent BuildTx -> Tx) -> TxBodyContent BuildTx -> Tx
forall a b. (a -> b) -> a -> b
$
    TxBodyContent BuildTx
emptyTxBody
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxIns BuildTx -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addInputs [(TxIn
headInput, BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness)]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxIn] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addReferenceInputs [TxIn
headScriptRef]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [TxOut CtxTx] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addOutputs [TxOut CtxTx
headOutputAfter]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& [Hash PaymentKey] -> TxBodyContent BuildTx -> TxBodyContent BuildTx
addExtraRequiredSigners [VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk]
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& SlotNo -> TxBodyContent BuildTx -> TxBodyContent BuildTx
setValidityUpperBound SlotNo
slotNo
      TxBodyContent BuildTx
-> (TxBodyContent BuildTx -> TxBodyContent BuildTx)
-> TxBodyContent BuildTx
forall a b. a -> (a -> b) -> b
& TxMetadataInEra Era
-> TxBodyContent BuildTx -> TxBodyContent BuildTx
forall era build.
TxMetadataInEra era
-> TxBodyContent build era -> TxBodyContent build era
setTxMetadata (TxMetadata -> TxMetadataInEra Era
TxMetadataInEra (TxMetadata -> TxMetadataInEra Era)
-> TxMetadata -> TxMetadataInEra Era
forall a b. (a -> b) -> a -> b
$ Text -> TxMetadata
mkHydraHeadV1TxName Text
"ContestTx")
 where
  ClosedThreadOutput
    { $sel:closedThreadUTxO:ClosedThreadOutput :: ClosedThreadOutput -> (TxIn, TxOut CtxUTxO)
closedThreadUTxO = (TxIn
headInput, TxOut CtxUTxO
headOutputBefore)
    , [Party]
$sel:closedParties:ClosedThreadOutput :: ClosedThreadOutput -> [Party]
closedParties :: [Party]
closedParties
    , POSIXTime
$sel:closedContestationDeadline:ClosedThreadOutput :: ClosedThreadOutput -> POSIXTime
closedContestationDeadline :: POSIXTime
closedContestationDeadline
    , [PubKeyHash]
$sel:closedContesters:ClosedThreadOutput :: ClosedThreadOutput -> [PubKeyHash]
closedContesters :: [PubKeyHash]
closedContesters
    } = ClosedThreadOutput
closedThreadOutput

  headWitness :: BuildTxWith BuildTx (Witness WitCtxTxIn)
headWitness =
    Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a. a -> BuildTxWith BuildTx a
BuildTxWith (Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn))
-> Witness WitCtxTxIn -> BuildTxWith BuildTx (Witness WitCtxTxIn)
forall a b. (a -> b) -> a -> b
$
      ScriptWitnessInCtx WitCtxTxIn
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall ctx.
ScriptWitnessInCtx ctx -> ScriptWitness ctx -> Witness ctx
ScriptWitness ScriptWitnessInCtx WitCtxTxIn
forall ctx. IsScriptWitnessInCtx ctx => ScriptWitnessInCtx ctx
scriptWitnessInCtx (ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn)
-> ScriptWitness WitCtxTxIn -> Witness WitCtxTxIn
forall a b. (a -> b) -> a -> b
$
        TxIn
-> PlutusScript PlutusScriptV2
-> ScriptDatum WitCtxTxIn
-> ScriptRedeemer
-> ScriptWitness WitCtxTxIn
forall ctx era lang.
(IsPlutusScriptLanguage lang, HasScriptLanguageInEra lang era) =>
TxIn
-> PlutusScript lang
-> ScriptDatum ctx
-> ScriptRedeemer
-> ScriptWitness ctx era
mkScriptReference TxIn
headScriptRef PlutusScript PlutusScriptV2
headScript ScriptDatum WitCtxTxIn
InlineScriptDatum ScriptRedeemer
headRedeemer

  headScriptRef :: TxIn
headScriptRef =
    (TxIn, TxOut CtxUTxO) -> TxIn
forall a b. (a, b) -> a
fst (ScriptRegistry -> (TxIn, TxOut CtxUTxO)
headReference ScriptRegistry
scriptRegistry)

  headScript :: PlutusScript PlutusScriptV2
headScript =
    forall lang. SerialisedScript -> PlutusScript lang
fromPlutusScript @PlutusScriptV2 SerialisedScript
Head.validatorScript

  headRedeemer :: ScriptRedeemer
headRedeemer = Input -> ScriptRedeemer
forall a. ToScriptData a => a -> ScriptRedeemer
toScriptData (Input -> ScriptRedeemer) -> Input -> ScriptRedeemer
forall a b. (a -> b) -> a -> b
$ ContestRedeemer -> Input
Head.Contest ContestRedeemer
contestRedeemer

  contestRedeemer :: ContestRedeemer
contestRedeemer
    | SnapshotVersion
version SnapshotVersion -> SnapshotVersion -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotVersion
openVersion =
        Head.ContestCurrent
          { $sel:signature:ContestCurrent :: [Signature]
signature = MultiSignature (Snapshot Tx) -> [Signature]
forall {k} (a :: k). MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot Tx)
sig
          }
    | Bool
otherwise =
        -- NOTE: This will only work for version == openVersion - 1
        Head.ContestOutdated
          { $sel:signature:ContestCurrent :: [Signature]
signature = MultiSignature (Snapshot Tx) -> [Signature]
forall {k} (a :: k). MultiSignature a -> [Signature]
toPlutusSignatures MultiSignature (Snapshot Tx)
sig
          , $sel:alreadyDecommittedUTxOHash:ContestCurrent :: Signature
alreadyDecommittedUTxOHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx (UTxOType Tx -> ByteString) -> UTxOType Tx -> ByteString
forall a b. (a -> b) -> a -> b
$ UTxO -> Maybe UTxO -> UTxO
forall a. a -> Maybe a -> a
fromMaybe UTxO
forall a. Monoid a => a
mempty Maybe UTxO
Maybe (UTxOType Tx)
utxoToDecommit
          }

  headOutputAfter :: TxOut CtxTx
headOutputAfter =
    (TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx Era)
-> TxOut CtxUTxO -> TxOut CtxTx
forall ctx0 era ctx1.
(TxOutDatum ctx0 era -> TxOutDatum ctx1 era)
-> TxOut ctx0 era -> TxOut ctx1 era
modifyTxOutDatum (TxOutDatum CtxTx Era
-> TxOutDatum CtxUTxO Era -> TxOutDatum CtxTx Era
forall a b. a -> b -> a
const TxOutDatum CtxTx Era
headDatumAfter) TxOut CtxUTxO
headOutputBefore

  contester :: PubKeyHash
contester = Hash PaymentKey -> PubKeyHash
toPlutusKeyHash (VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash VerificationKey PaymentKey
vk)

  onChainConstestationPeriod :: ContestationPeriod
onChainConstestationPeriod = ContestationPeriod -> ContestationPeriod
toChain ContestationPeriod
contestationPeriod

  newContestationDeadline :: POSIXTime
newContestationDeadline =
    if [PubKeyHash] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PubKeyHash
contester PubKeyHash -> [PubKeyHash] -> [PubKeyHash]
forall a. a -> [a] -> [a]
: [PubKeyHash]
closedContesters) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Party] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Party]
closedParties
      then POSIXTime
closedContestationDeadline
      else POSIXTime -> ContestationPeriod -> POSIXTime
addContestationPeriod POSIXTime
closedContestationDeadline ContestationPeriod
onChainConstestationPeriod

  headDatumAfter :: TxOutDatum CtxTx Era
headDatumAfter =
    State -> TxOutDatum CtxTx Era
forall era a ctx.
(ToScriptData a, IsBabbageBasedEra era) =>
a -> TxOutDatum ctx era
mkTxOutDatumInline (State -> TxOutDatum CtxTx Era) -> State -> TxOutDatum CtxTx Era
forall a b. (a -> b) -> a -> b
$
      ClosedDatum -> State
Head.Closed
        Head.ClosedDatum
          { $sel:snapshotNumber:ClosedDatum :: SnapshotVersion
snapshotNumber = SnapshotNumber -> SnapshotVersion
forall a. Integral a => a -> SnapshotVersion
toInteger SnapshotNumber
number
          , $sel:utxoHash:ClosedDatum :: Signature
utxoHash = ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxOType Tx
utxo
          , $sel:deltaUTxOHash:ClosedDatum :: Signature
deltaUTxOHash =
              case ContestRedeemer
contestRedeemer of
                Head.ContestCurrent{} ->
                  ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx (UTxOType Tx -> ByteString) -> UTxOType Tx -> ByteString
forall a b. (a -> b) -> a -> b
$ UTxO -> Maybe UTxO -> UTxO
forall a. a -> Maybe a -> a
fromMaybe UTxO
forall a. Monoid a => a
mempty Maybe UTxO
Maybe (UTxOType Tx)
utxoToDecommit
                ContestRedeemer
_ -> ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> ToBuiltin ByteString)
-> ByteString -> ToBuiltin ByteString
forall a b. (a -> b) -> a -> b
$ forall tx. IsTx tx => UTxOType tx -> ByteString
hashUTxO @Tx UTxO
UTxOType Tx
forall a. Monoid a => a
mempty
          , $sel:parties:ClosedDatum :: [Party]
parties = [Party]
closedParties
          , $sel:contestationDeadline:ClosedDatum :: POSIXTime
contestationDeadline = POSIXTime
newContestationDeadline
          , $sel:contestationPeriod:ClosedDatum :: ContestationPeriod
contestationPeriod = ContestationPeriod
onChainConstestationPeriod
          , $sel:headId:ClosedDatum :: CurrencySymbol
headId = HeadId -> CurrencySymbol
headIdToCurrencySymbol HeadId
headId
          , $sel:contesters:ClosedDatum :: [PubKeyHash]
contesters = PubKeyHash
contester PubKeyHash -> [PubKeyHash] -> [PubKeyHash]
forall a. a -> [a] -> [a]
: [PubKeyHash]
closedContesters
          , $sel:version:ClosedDatum :: SnapshotVersion
version = SnapshotVersion -> SnapshotVersion
forall a. Integral a => a -> SnapshotVersion
toInteger SnapshotVersion
openVersion
          }