{-# LANGUAGE TemplateHaskell #-}

-- | 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, fromPlutusTxOut, fromPlutusTxOutRef, toPlutusTxOut, toPlutusTxOutRef)
import Hydra.Cardano.Api qualified as OffChain
import Hydra.Cardano.Api.Network (Network)
import Hydra.Data.Party (Party)
import PlutusLedgerApi.V3 (
  CurrencySymbol,
  Datum (..),
  Redeemer (Redeemer),
  TxOutRef,
 )
import PlutusTx (fromData, toBuiltinData, toData)
import PlutusTx qualified
import Prelude qualified as Haskell

-- | 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.
IsBabbageBasedEra 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)

data CommitRedeemer
  = ViaCollectCom
  | ViaAbort

PlutusTx.unstableMakeIsData ''CommitRedeemer

-- TODO: Note that we now have datum and the redeemer duplicated in haskell and
-- on aiken side. Idea is to remove these types from haskell land but we want to
-- wait on the plutus team to implement
-- [CIP-57](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0057)
-- which will allow us to parse the 'plutus.json' datum and redeemer definitions
-- directly to Plutus `Data` .
type RedeemerType = CommitRedeemer

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)