{-# 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.0.0 #-}

-- | The validator used to collect & open or abort a Head.
module Hydra.Contract.Commit where

import PlutusTx.Prelude

import Codec.Serialise (deserialiseOrFail, serialise)
import Data.ByteString.Lazy (fromStrict, toStrict)
import Hydra.Cardano.Api (CtxUTxO, PlutusScriptVersion (PlutusScriptV2), fromPlutusTxOut, fromPlutusTxOutRef, toPlutusTxOut, toPlutusTxOutRef)
import Hydra.Cardano.Api qualified as OffChain
import Hydra.Cardano.Api.Network (Network)
import Hydra.Contract.CommitError (CommitError (..), errorCode)
import Hydra.Contract.Util (hasST, mustBurnST)
import Hydra.Data.Party (Party)
import Hydra.Plutus.Extras (ValidatorType, scriptValidatorHash, wrapValidator)
import Hydra.ScriptContext (ScriptContext (..), TxInfo (..))
import PlutusLedgerApi.V2 (
  CurrencySymbol,
  Datum (..),
  Redeemer (Redeemer),
  ScriptHash,
  SerialisedScript,
  TxOutRef,
  serialiseCompiledCode,
  txOutValue,
 )
import PlutusTx (CompiledCode, fromData, toBuiltinData, toData)
import PlutusTx qualified
import Prelude qualified as Haskell

data CommitRedeemer
  = ViaCollectCom
  | ViaAbort

PlutusTx.unstableMakeIsData ''CommitRedeemer

-- | A data type representing comitted outputs on-chain. Besides recording the
-- original 'TxOutRef', it also stores a binary representation compatible
-- between on- and off-chain code to be hashed in the validators.
data Commit = Commit
  { Commit -> TxOutRef
input :: TxOutRef
  , Commit -> BuiltinByteString
preSerializedOutput :: BuiltinByteString
  }
  deriving stock (Commit -> Commit -> Bool
(Commit -> Commit -> Bool)
-> (Commit -> Commit -> Bool) -> Eq Commit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Commit -> Commit -> Bool
== :: Commit -> Commit -> Bool
$c/= :: Commit -> Commit -> Bool
/= :: Commit -> Commit -> Bool
Haskell.Eq, Int -> Commit -> ShowS
[Commit] -> ShowS
Commit -> String
(Int -> Commit -> ShowS)
-> (Commit -> String) -> ([Commit] -> ShowS) -> Show Commit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Commit -> ShowS
showsPrec :: Int -> Commit -> ShowS
$cshow :: Commit -> String
show :: Commit -> String
$cshowList :: [Commit] -> ShowS
showList :: [Commit] -> ShowS
Haskell.Show, Eq Commit
Eq Commit =>
(Commit -> Commit -> Ordering)
-> (Commit -> Commit -> Bool)
-> (Commit -> Commit -> Bool)
-> (Commit -> Commit -> Bool)
-> (Commit -> Commit -> Bool)
-> (Commit -> Commit -> Commit)
-> (Commit -> Commit -> Commit)
-> Ord Commit
Commit -> Commit -> Bool
Commit -> Commit -> Ordering
Commit -> Commit -> Commit
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Commit -> Commit -> Ordering
compare :: Commit -> Commit -> Ordering
$c< :: Commit -> Commit -> Bool
< :: Commit -> Commit -> Bool
$c<= :: Commit -> Commit -> Bool
<= :: Commit -> Commit -> Bool
$c> :: Commit -> Commit -> Bool
> :: Commit -> Commit -> Bool
$c>= :: Commit -> Commit -> Bool
>= :: Commit -> Commit -> Bool
$cmax :: Commit -> Commit -> Commit
max :: Commit -> Commit -> Commit
$cmin :: Commit -> Commit -> Commit
min :: Commit -> Commit -> Commit
Haskell.Ord)

instance Eq Commit where
  (Commit TxOutRef
i BuiltinByteString
o) == :: Commit -> Commit -> Bool
== (Commit TxOutRef
i' BuiltinByteString
o') =
    TxOutRef
i TxOutRef -> TxOutRef -> Bool
forall a. Eq a => a -> a -> Bool
== TxOutRef
i' Bool -> Bool -> Bool
&& BuiltinByteString
o BuiltinByteString -> BuiltinByteString -> Bool
forall a. Eq a => a -> a -> Bool
== BuiltinByteString
o'

PlutusTx.unstableMakeIsData ''Commit

-- | Record an off-chain 'TxOut' as a 'Commit' on-chain.
-- NOTE: Depends on the 'Serialise' instance for Plutus' 'Data'.
serializeCommit :: (OffChain.TxIn, OffChain.TxOut CtxUTxO) -> Maybe Commit
serializeCommit :: (TxIn, TxOut CtxUTxO) -> Maybe Commit
serializeCommit (TxIn
i, TxOut CtxUTxO
o) = do
  BuiltinByteString
preSerializedOutput <- ByteString -> BuiltinByteString
ByteString -> ToBuiltin ByteString
forall a. HasToBuiltin a => a -> ToBuiltin a
toBuiltin (ByteString -> BuiltinByteString)
-> (TxOut -> ByteString) -> TxOut -> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (TxOut -> ByteString) -> TxOut -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> ByteString
forall a. Serialise a => a -> ByteString
serialise (Data -> ByteString) -> (TxOut -> Data) -> TxOut -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut -> Data
forall a. ToData a => a -> Data
toData (TxOut -> BuiltinByteString)
-> Maybe TxOut -> Maybe BuiltinByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => TxOut CtxUTxO -> Maybe TxOut
TxOut CtxUTxO -> Maybe TxOut
toPlutusTxOut TxOut CtxUTxO
o
  Commit -> Maybe Commit
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Commit
      { input :: TxOutRef
input = TxIn -> TxOutRef
toPlutusTxOutRef TxIn
i
      , BuiltinByteString
preSerializedOutput :: BuiltinByteString
preSerializedOutput :: BuiltinByteString
preSerializedOutput
      }

-- | Decode an on-chain 'SerializedTxOut' back into an off-chain 'TxOut'.
-- NOTE: Depends on the 'Serialise' instance for Plutus' 'Data'.
deserializeCommit :: Network -> Commit -> Maybe (OffChain.TxIn, OffChain.TxOut CtxUTxO)
deserializeCommit :: Network -> Commit -> Maybe (TxIn, TxOut CtxUTxO)
deserializeCommit Network
network Commit{TxOutRef
input :: Commit -> TxOutRef
input :: TxOutRef
input, BuiltinByteString
preSerializedOutput :: Commit -> BuiltinByteString
preSerializedOutput :: BuiltinByteString
preSerializedOutput} =
  case ByteString -> Either DeserialiseFailure Data
forall a. Serialise a => ByteString -> Either DeserialiseFailure a
deserialiseOrFail (ByteString -> Either DeserialiseFailure Data)
-> (ByteString -> ByteString)
-> ByteString
-> Either DeserialiseFailure Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict (ByteString -> Either DeserialiseFailure Data)
-> ByteString -> Either DeserialiseFailure Data
forall a b. (a -> b) -> a -> b
$ BuiltinByteString -> FromBuiltin BuiltinByteString
forall arep. HasFromBuiltin arep => arep -> FromBuiltin arep
fromBuiltin BuiltinByteString
preSerializedOutput of
    Left{} -> Maybe (TxIn, TxOut CtxUTxO)
forall a. Maybe a
Nothing
    Right Data
dat -> do
      TxOut CtxUTxO
txOut <- Network -> TxOut -> Maybe (TxOut CtxUTxO)
forall era.
(IsMaryBasedEra era, IsAlonzoBasedEra era, IsBabbageBasedEra era,
 IsShelleyBasedEra era) =>
Network -> TxOut -> Maybe (TxOut CtxUTxO era)
fromPlutusTxOut Network
network (TxOut -> Maybe (TxOut CtxUTxO))
-> Maybe TxOut -> Maybe (TxOut CtxUTxO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Data -> Maybe TxOut
forall a. FromData a => Data -> Maybe a
fromData Data
dat
      (TxIn, TxOut CtxUTxO) -> Maybe (TxIn, TxOut CtxUTxO)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOutRef -> TxIn
fromPlutusTxOutRef TxOutRef
input, TxOut CtxUTxO
txOut)

-- TODO: Party is not used on-chain but is needed off-chain while it's still
-- based on mock crypto. When we move to real crypto we could simply use
-- the PT's token name to identify the committing party
type DatumType = (Party, [Commit], CurrencySymbol)
type RedeemerType = CommitRedeemer

-- | The v_commit validator verifies that:
--
--   * spent in a transaction also consuming a v_head output
--
--   * ST is burned if the redeemer is 'ViaAbort'
--
--   * ST is present in the output if the redeemer is 'ViaCollectCom'
validator :: DatumType -> RedeemerType -> ScriptContext -> Bool
validator :: DatumType -> RedeemerType -> ScriptContext -> Bool
validator (Party
_party, [Commit]
_commit, CurrencySymbol
headId) RedeemerType
r ScriptContext
ctx =
  case RedeemerType
r of
    -- NOTE: The reimbursement of the committed output 'commit' is
    -- delegated to the 'head' script who has more information to do it.
    RedeemerType
ViaAbort ->
      BuiltinString -> Bool -> Bool
traceIfFalse
        $(errorCode STNotBurnedError)
        (Value -> CurrencySymbol -> Bool
mustBurnST (TxInfo -> Value
txInfoMint (TxInfo -> Value) -> TxInfo -> Value
forall a b. (a -> b) -> a -> b
$ ScriptContext -> TxInfo
scriptContextTxInfo ScriptContext
ctx) CurrencySymbol
headId)
    RedeemerType
ViaCollectCom ->
      BuiltinString -> Bool -> Bool
traceIfFalse
        $(errorCode STIsMissingInTheOutput)
        (CurrencySymbol -> Value -> Bool
hasST CurrencySymbol
headId Value
headOutputValue)
 where
  headOutputValue :: Value
headOutputValue =
    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 (ScriptContext -> TxInfo
scriptContextTxInfo ScriptContext
ctx)

compiledValidator :: CompiledCode ValidatorType
compiledValidator :: CompiledCode ValidatorType
compiledValidator =
  $$(PlutusTx.compile [||wrap validator||])
 where
  wrap :: (DatumType -> RedeemerType -> 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

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)