module Hydra.Tx.Utils where

import Hydra.Cardano.Api
import Hydra.Prelude hiding (toList)

import Cardano.Ledger.Api (AlonzoTxAuxData (..), auxDataHashTxBodyL, auxDataTxL, bodyTxL, hashTxAuxData)
import Cardano.Ledger.Core (TxLevel (..))
import Cardano.Ledger.Core qualified as LedgerCore
import Control.Lens ((.~), (^.))
import Data.Map.Strict qualified as Map
import Data.Maybe.Strict (StrictMaybe (..))
import GHC.IsList (IsList (..))
import Hydra.Contract.Util (hydraHeadV2)
import Hydra.Tx.HeadId (HeadId, mkHeadId)
import Hydra.Tx.OnChainId (OnChainId (..))
import PlutusLedgerApi.V3 (fromBuiltin, getPubKeyHash)

hydraHeadV2AssetName :: AssetName
hydraHeadV2AssetName :: AssetName
hydraHeadV2AssetName = ByteString -> AssetName
UnsafeAssetName (BuiltinByteString -> FromBuiltin BuiltinByteString
forall arep. HasFromBuiltin arep => arep -> FromBuiltin arep
fromBuiltin BuiltinByteString
hydraHeadV2)

-- | The metadata label used for identifying Hydra protocol transactions. As
-- suggested by a friendly large language model: The number most commonly
-- associated with "Hydra" is 5, as in the mythological creature Hydra, which
-- had multiple heads, and the number 5 often symbolizes multiplicity or
-- diversity. However, there is no specific numerical association for Hydra
-- smaller than 10000 beyond this mythological reference.
hydraMetadataLabel :: Word64
hydraMetadataLabel :: Word64
hydraMetadataLabel = Word64
55555

-- | Create a transaction metadata entry to identify Hydra transactions (for
-- informational purposes).
mkHydraHeadV2TxName :: Text -> TxMetadata
mkHydraHeadV2TxName :: Text -> TxMetadata
mkHydraHeadV2TxName Text
name =
  Map Word64 TxMetadataValue -> TxMetadata
TxMetadata (Map Word64 TxMetadataValue -> TxMetadata)
-> Map Word64 TxMetadataValue -> TxMetadata
forall a b. (a -> b) -> a -> b
$ [(Word64, TxMetadataValue)] -> Map Word64 TxMetadataValue
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64
hydraMetadataLabel, Text -> TxMetadataValue
TxMetaText (Text -> TxMetadataValue) -> Text -> TxMetadataValue
forall a b. (a -> b) -> a -> b
$ Text
"HydraV2/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)]

assetNameToOnChainId :: AssetName -> OnChainId
assetNameToOnChainId :: AssetName -> OnChainId
assetNameToOnChainId (UnsafeAssetName ByteString
bs) = ByteString -> OnChainId
UnsafeOnChainId ByteString
bs

onChainIdToAssetName :: OnChainId -> AssetName
onChainIdToAssetName :: OnChainId -> AssetName
onChainIdToAssetName = ByteString -> AssetName
UnsafeAssetName (ByteString -> AssetName)
-> (OnChainId -> ByteString) -> OnChainId -> AssetName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OnChainId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes

-- | Find first occurrence including a transformation.
findFirst :: Foldable t => (a -> Maybe b) -> t a -> Maybe b
findFirst :: forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
findFirst a -> Maybe b
fn = First b -> Maybe b
forall a. First a -> Maybe a
getFirst (First b -> Maybe b) -> (t a -> First b) -> t a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> First b) -> t a -> First b
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe b -> First b
forall a. Maybe a -> First a
First (Maybe b -> First b) -> (a -> Maybe b) -> a -> First b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
fn)

-- | Derive the 'OnChainId' from a Cardano 'PaymentKey'. The on-chain identifier
-- is the public key hash as it is also available to plutus validators.
verificationKeyToOnChainId :: VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId :: VerificationKey PaymentKey -> OnChainId
verificationKeyToOnChainId =
  ByteString -> OnChainId
UnsafeOnChainId (ByteString -> OnChainId)
-> (VerificationKey PaymentKey -> ByteString)
-> VerificationKey PaymentKey
-> OnChainId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinByteString -> ByteString
BuiltinByteString -> FromBuiltin BuiltinByteString
forall arep. HasFromBuiltin arep => arep -> FromBuiltin arep
fromBuiltin (BuiltinByteString -> ByteString)
-> (VerificationKey PaymentKey -> BuiltinByteString)
-> VerificationKey PaymentKey
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PubKeyHash -> BuiltinByteString
getPubKeyHash (PubKeyHash -> BuiltinByteString)
-> (VerificationKey PaymentKey -> PubKeyHash)
-> VerificationKey PaymentKey
-> BuiltinByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash PaymentKey -> PubKeyHash
toPlutusKeyHash (Hash PaymentKey -> PubKeyHash)
-> (VerificationKey PaymentKey -> Hash PaymentKey)
-> VerificationKey PaymentKey
-> PubKeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationKey PaymentKey -> Hash PaymentKey
forall keyrole.
Key keyrole =>
VerificationKey keyrole -> Hash keyrole
verificationKeyHash

headTokensFromValue :: PlutusScript -> Value -> PolicyAssets
headTokensFromValue :: PlutusScript -> Value -> PolicyAssets
headTokensFromValue PlutusScript
headTokenScript Value
v =
  [Item PolicyAssets] -> PolicyAssets
forall l. IsList l => [Item l] -> l
fromList ([Item PolicyAssets] -> PolicyAssets)
-> [Item PolicyAssets] -> PolicyAssets
forall a b. (a -> b) -> a -> b
$
    [ (AssetName
assetName, Quantity
q)
    | (AssetId PolicyId
pid AssetName
assetName, Quantity
q) <- Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList Value
v
    , PolicyId
pid PolicyId -> PolicyId -> Bool
forall a. Eq a => a -> a -> Bool
== Script PlutusScriptV3 -> PolicyId
forall lang. Script lang -> PolicyId
scriptPolicyId (PlutusScript -> Script PlutusScriptV3
PlutusScript PlutusScript
headTokenScript)
    ]

addMetadata :: TxMetadata -> Tx -> LedgerCore.Tx TopTx LedgerEra -> LedgerCore.Tx TopTx LedgerEra
addMetadata :: TxMetadata -> Tx -> Tx TopTx LedgerEra -> Tx TopTx LedgerEra
addMetadata (TxMetadata Map Word64 TxMetadataValue
newMetadata) Tx
blueprintTx Tx TopTx LedgerEra
tx =
  let
    newMetadataMap :: Map Word64 Metadatum
newMetadataMap = Map Word64 TxMetadataValue -> Map Word64 Metadatum
toShelleyMetadata Map Word64 TxMetadataValue
newMetadata
    newAuxData :: AlonzoTxAuxData ConwayEra
newAuxData =
      case Tx -> Tx TopTx LedgerEra
forall era. Tx era -> Tx TopTx (ShelleyLedgerEra era)
toLedgerTx Tx
blueprintTx Tx TopTx ConwayEra
-> Getting
     (StrictMaybe (AlonzoTxAuxData ConwayEra))
     (Tx TopTx ConwayEra)
     (StrictMaybe (AlonzoTxAuxData ConwayEra))
-> StrictMaybe (AlonzoTxAuxData ConwayEra)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (AlonzoTxAuxData ConwayEra))
  (Tx TopTx ConwayEra)
  (StrictMaybe (AlonzoTxAuxData ConwayEra))
(StrictMaybe (TxAuxData ConwayEra)
 -> Const
      (StrictMaybe (AlonzoTxAuxData ConwayEra))
      (StrictMaybe (TxAuxData ConwayEra)))
-> Tx TopTx ConwayEra
-> Const
     (StrictMaybe (AlonzoTxAuxData ConwayEra)) (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l ConwayEra) (StrictMaybe (TxAuxData ConwayEra))
auxDataTxL of
        StrictMaybe (AlonzoTxAuxData ConwayEra)
SNothing -> Map Word64 Metadatum
-> StrictSeq (NativeScript ConwayEra)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData ConwayEra
forall era.
(HasCallStack, AlonzoEraScript era) =>
Map Word64 Metadatum
-> StrictSeq (NativeScript era)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData era
AlonzoTxAuxData Map Word64 Metadatum
newMetadataMap StrictSeq (NativeScript ConwayEra)
forall a. Monoid a => a
mempty Map Language (NonEmpty PlutusBinary)
forall a. Monoid a => a
mempty
        SJust (AlonzoTxAuxData Map Word64 Metadatum
metadata StrictSeq (NativeScript ConwayEra)
timeLocks Map Language (NonEmpty PlutusBinary)
languageMap) ->
          Map Word64 Metadatum
-> StrictSeq (NativeScript ConwayEra)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData ConwayEra
forall era.
(HasCallStack, AlonzoEraScript era) =>
Map Word64 Metadatum
-> StrictSeq (NativeScript era)
-> Map Language (NonEmpty PlutusBinary)
-> AlonzoTxAuxData era
AlonzoTxAuxData (Map Word64 Metadatum
-> Map Word64 Metadatum -> Map Word64 Metadatum
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Word64 Metadatum
metadata Map Word64 Metadatum
newMetadataMap) StrictSeq (NativeScript ConwayEra)
timeLocks Map Language (NonEmpty PlutusBinary)
languageMap
   in
    Tx TopTx LedgerEra
Tx TopTx ConwayEra
tx
      Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (StrictMaybe (AlonzoTxAuxData ConwayEra)
 -> Identity (StrictMaybe (AlonzoTxAuxData ConwayEra)))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
(StrictMaybe (TxAuxData ConwayEra)
 -> Identity (StrictMaybe (TxAuxData ConwayEra)))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (StrictMaybe (TxAuxData era))
forall (l :: TxLevel).
Lens' (Tx l ConwayEra) (StrictMaybe (TxAuxData ConwayEra))
auxDataTxL ((StrictMaybe (AlonzoTxAuxData ConwayEra)
  -> Identity (StrictMaybe (AlonzoTxAuxData ConwayEra)))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictMaybe (AlonzoTxAuxData ConwayEra)
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ AlonzoTxAuxData ConwayEra
-> StrictMaybe (AlonzoTxAuxData ConwayEra)
forall a. a -> StrictMaybe a
SJust AlonzoTxAuxData ConwayEra
newAuxData
      Tx TopTx ConwayEra
-> (Tx TopTx ConwayEra -> Tx TopTx ConwayEra) -> Tx TopTx ConwayEra
forall a b. a -> (a -> b) -> b
& (TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l ConwayEra) (TxBody l ConwayEra)
bodyTxL ((TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> ((StrictMaybe TxAuxDataHash
     -> Identity (StrictMaybe TxAuxDataHash))
    -> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra))
-> (StrictMaybe TxAuxDataHash
    -> Identity (StrictMaybe TxAuxDataHash))
-> Tx TopTx ConwayEra
-> Identity (Tx TopTx ConwayEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash -> Identity (StrictMaybe TxAuxDataHash))
-> TxBody TopTx ConwayEra -> Identity (TxBody TopTx ConwayEra)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictMaybe TxAuxDataHash)
forall (l :: TxLevel).
Lens' (TxBody l ConwayEra) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL ((StrictMaybe TxAuxDataHash
  -> Identity (StrictMaybe TxAuxDataHash))
 -> Tx TopTx ConwayEra -> Identity (Tx TopTx ConwayEra))
-> StrictMaybe TxAuxDataHash
-> Tx TopTx ConwayEra
-> Tx TopTx ConwayEra
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxAuxDataHash -> StrictMaybe TxAuxDataHash
forall a. a -> StrictMaybe a
SJust (TxAuxData ConwayEra -> TxAuxDataHash
forall era. EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData AlonzoTxAuxData ConwayEra
TxAuxData ConwayEra
newAuxData)

-- | Type to encapsulate one of the two possible incremental actions or a
-- regular snapshot. This actually signals that our snapshot modeling is likely
-- not ideal but for now we want to keep track of both fields (de/commit) since
-- we might want to support batch de/commits too in the future, but having both fields
-- be Maybe UTxO introduces a lot of checks if the value is Nothing or mempty.
--
-- TODO: Remove this type. Since GHSA-f825-9gwc-h5xq, 'Hydra.Tx.Close.closeTx'
-- no longer distinguishes 'ToCommit' from 'ToDecommit' (which accumulator to
-- store is decided by comparing the snapshot version with the open version),
-- so the only remaining uses are picking 'CloseAny' when nothing is pending
-- and rejecting a snapshot with both a commit and a decommit. Both can be
-- expressed directly on the snapshot's 'utxoToCommit' / 'utxoToDecommit'.
data IncrementalAction = ToCommit | ToDecommit | NoThing deriving stock (IncrementalAction -> IncrementalAction -> Bool
(IncrementalAction -> IncrementalAction -> Bool)
-> (IncrementalAction -> IncrementalAction -> Bool)
-> Eq IncrementalAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IncrementalAction -> IncrementalAction -> Bool
== :: IncrementalAction -> IncrementalAction -> Bool
$c/= :: IncrementalAction -> IncrementalAction -> Bool
/= :: IncrementalAction -> IncrementalAction -> Bool
Eq, Int -> IncrementalAction -> ShowS
[IncrementalAction] -> ShowS
IncrementalAction -> String
(Int -> IncrementalAction -> ShowS)
-> (IncrementalAction -> String)
-> ([IncrementalAction] -> ShowS)
-> Show IncrementalAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IncrementalAction -> ShowS
showsPrec :: Int -> IncrementalAction -> ShowS
$cshow :: IncrementalAction -> String
show :: IncrementalAction -> String
$cshowList :: [IncrementalAction] -> ShowS
showList :: [IncrementalAction] -> ShowS
Show)

setIncrementalActionMaybe :: Maybe UTxO -> Maybe UTxO -> Maybe IncrementalAction
setIncrementalActionMaybe :: Maybe UTxO -> Maybe UTxO -> Maybe IncrementalAction
setIncrementalActionMaybe Maybe UTxO
utxoToCommit Maybe UTxO
utxoToDecommit =
  case (Maybe UTxO
utxoToCommit, Maybe UTxO
utxoToDecommit) of
    (Just UTxO
_, Just UTxO
_) -> Maybe IncrementalAction
forall a. Maybe a
Nothing
    (Just UTxO
_, Maybe UTxO
Nothing) -> IncrementalAction -> Maybe IncrementalAction
forall a. a -> Maybe a
Just IncrementalAction
ToCommit
    (Maybe UTxO
Nothing, Just UTxO
_) -> IncrementalAction -> Maybe IncrementalAction
forall a. a -> Maybe a
Just IncrementalAction
ToDecommit
    (Maybe UTxO
Nothing, Maybe UTxO
Nothing) -> IncrementalAction -> Maybe IncrementalAction
forall a. a -> Maybe a
Just IncrementalAction
NoThing

-- | Find (if it exists) the head identifier contained in given `TxOut`.
findStateToken :: TxOut ctx -> Maybe HeadId
findStateToken :: forall ctx. TxOut ctx -> Maybe HeadId
findStateToken =
  ((PolicyId, AssetName) -> HeadId)
-> Maybe (PolicyId, AssetName) -> Maybe HeadId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PolicyId -> HeadId
mkHeadId (PolicyId -> HeadId)
-> ((PolicyId, AssetName) -> PolicyId)
-> (PolicyId, AssetName)
-> HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PolicyId, AssetName) -> PolicyId
forall a b. (a, b) -> a
fst) (Maybe (PolicyId, AssetName) -> Maybe HeadId)
-> (TxOut ctx -> Maybe (PolicyId, AssetName))
-> TxOut ctx
-> Maybe HeadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut ctx -> Maybe (PolicyId, AssetName)
forall ctx. TxOut ctx -> Maybe (PolicyId, AssetName)
findHeadAssetId

findHeadAssetId :: TxOut ctx -> Maybe (PolicyId, AssetName)
findHeadAssetId :: forall ctx. TxOut ctx -> Maybe (PolicyId, AssetName)
findHeadAssetId TxOut ctx
txOut =
  (((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
 -> [(AssetId, Quantity)] -> Maybe (PolicyId, AssetName))
-> [(AssetId, Quantity)]
-> ((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
-> Maybe (PolicyId, AssetName)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
-> [(AssetId, Quantity)] -> Maybe (PolicyId, AssetName)
forall (t :: * -> *) a b.
Foldable t =>
(a -> Maybe b) -> t a -> Maybe b
findFirst (Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList (Value -> [Item Value]) -> Value -> [Item Value]
forall a b. (a -> b) -> a -> b
$ TxOut ctx -> Value
forall ctx. TxOut ctx -> Value
txOutValue TxOut ctx
txOut) (((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
 -> Maybe (PolicyId, AssetName))
-> ((AssetId, Quantity) -> Maybe (PolicyId, AssetName))
-> Maybe (PolicyId, AssetName)
forall a b. (a -> b) -> a -> b
$ \case
    (AssetId PolicyId
pid AssetName
aname, Quantity
q)
      | AssetName
aname AssetName -> AssetName -> Bool
forall a. Eq a => a -> a -> Bool
== AssetName
hydraHeadV2AssetName Bool -> Bool -> Bool
&& Quantity
q Quantity -> Quantity -> Bool
forall a. Eq a => a -> a -> Bool
== Quantity
1 ->
          (PolicyId, AssetName) -> Maybe (PolicyId, AssetName)
forall a. a -> Maybe a
Just (PolicyId
pid, AssetName
aname)
    (AssetId, Quantity)
_ ->
      Maybe (PolicyId, AssetName)
forall a. Maybe a
Nothing