Some conversion functions from Plutus to Cardano.Api

IntersectMBO · Jun 8, 2021 · e809cea · e809cea
1 parent 594e81d
commit e809cea
Show file tree

Hide file tree

Showing 2 changed files with 138 additions and 28 deletions.
diff --git a/cabal.project b/cabal.project
@@ -123,7 +123,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-node
-  tag: 8c142704e7df8ca857b179e26fdebb6919b5a7a6
+  tag: 31f80825dbf1ae199dbe9e9349aea9c814d15fa6
   subdir:
     cardano-api
 

diff --git a/plutus-contract/src/Plutus/Contract/CardanoAPI.hs b/plutus-contract/src/Plutus/Contract/CardanoAPI.hs
@@ -1,33 +1,53 @@
 {-# LANGUAGE GADTs           #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns    #-}
-{-
+{-|
 
 Interface to the transaction types from 'cardano-api'
 
 -}
 module Plutus.Contract.CardanoAPI(
     fromCardanoTx
+  , fromCardanoTxIn
+  , fromCardanoTxInsCollateral
   , fromCardanoTxInWitness
+  , fromCardanoTxOut
+  , fromCardanoMintValue
   , fromCardanoValue
+  , fromCardanoFee
+  , fromCardanoValidityRange
+  , fromCardanoAuxScriptData
+  , fromCardanoTxAuxScripts
+  , toCardanoTxIn
+  , toCardanoTxInsCollateral
+  , toCardanoTxInWitness
+  , toCardanoTxOut
+  , toCardanoMintValue
+  , toCardanoValue
+  , toCardanoFee
+  , toCardanoValidityRange
+  , toCardanoAuxScriptData
+  , toCardanoTxAuxScripts
 ) where
 
 import qualified Cardano.Api            as C
+import qualified Cardano.Api.Shelley    as C
 import qualified Cardano.Ledger.Era     as C
-import           Codec.Serialise        (deserialise)
-import           Data.Bifunctor         (bimap)
+import qualified Codec.Serialise        as Codec
 import qualified Data.ByteString.Lazy   as BSL
+import           Data.ByteString.Short  as BSS
 import qualified Data.Map               as Map
 import           Data.Maybe             (mapMaybe)
 import qualified Data.Set               as Set
 import qualified Ledger                 as P
 import qualified Ledger.Ada             as Ada
+import qualified Plutus.V1.Ledger.Api   as Api
 import qualified Plutus.V1.Ledger.Value as Value
 import qualified PlutusTx.Data          as Data
 
 fromCardanoTx :: C.Era era => C.Tx era -> P.Tx
-fromCardanoTx (C.Tx (C.TxBody (C.TxBodyContent{..})) keyWitnesses) = P.Tx
-  { txInputs = Set.fromList $ fmap (P.pubKeyTxIn . fromCardanoTxIn . fst) $ txIns -- TODO: can create TxInType only with a Build Tx
+fromCardanoTx (C.Tx (C.TxBody C.TxBodyContent{..}) keyWitnesses) = P.Tx
+  { txInputs = Set.fromList $ fmap (P.pubKeyTxIn . fromCardanoTxIn . fst) txIns -- TODO: can create TxInType only with a Build Tx
   , txCollateral = fromCardanoTxInsCollateral txInsCollateral
   , txOutputs = map fromCardanoTxOut txOuts
   , txForge = fromCardanoMintValue txMintValue
@@ -42,93 +62,168 @@ fromCardanoTx (C.Tx (C.TxBody (C.TxBodyContent{..})) keyWitnesses) = P.Tx
 fromCardanoTxIn :: C.TxIn -> P.TxOutRef
 fromCardanoTxIn (C.TxIn txId (C.TxIx txIx)) = P.TxOutRef (fromCardanoTxId txId) (toInteger txIx)
 
+toCardanoTxIn :: P.TxOutRef -> Maybe C.TxIn
+toCardanoTxIn (P.TxOutRef txId txIx) = C.TxIn <$> toCardanoTxId txId <*> pure (C.TxIx (fromInteger txIx))
+
 fromCardanoTxId :: C.TxId -> P.TxId
 fromCardanoTxId txId = P.TxId $ C.serialiseToRawBytes txId
 
+toCardanoTxId :: P.TxId -> Maybe C.TxId
+toCardanoTxId (P.TxId bs) = C.deserialiseFromRawBytes C.AsTxId bs
+
 fromCardanoTxInsCollateral :: C.TxInsCollateral era -> Set.Set P.TxIn
 fromCardanoTxInsCollateral C.TxInsCollateralNone       = mempty
-fromCardanoTxInsCollateral (C.TxInsCollateral _ txIns) = Set.fromList $ map (P.pubKeyTxIn . fromCardanoTxIn) $ txIns
+fromCardanoTxInsCollateral (C.TxInsCollateral _ txIns) = Set.fromList $ fmap (P.pubKeyTxIn . fromCardanoTxIn) txIns
+
+toCardanoTxInsCollateral :: Set.Set P.TxIn -> Maybe (C.TxInsCollateral C.AlonzoEra)
+toCardanoTxInsCollateral = fmap (C.TxInsCollateral C.CollateralInAlonzoEra) . traverse (toCardanoTxIn . P.txInRef) . Set.toList
 
 fromCardanoTxInWitness :: C.Witness C.WitCtxTxIn era -> Maybe P.TxInType
-fromCardanoTxInWitness (C.KeyWitness C.KeyWitnessForSpending) = Just P.ConsumePublicKeyAddress
+fromCardanoTxInWitness (C.KeyWitness C.KeyWitnessForSpending) = pure P.ConsumePublicKeyAddress
 fromCardanoTxInWitness
     (C.ScriptWitness _
-        (C.PlutusScriptWitness
-            C.PlutusScriptV1InAlonzo
-            C.PlutusScriptV1
+        (C.PlutusScriptWitness C.PlutusScriptV1InAlonzo C.PlutusScriptV1
             script
             (C.ScriptDatumForTxIn datum)
             redeemer
             _))
-    = Just $ P.ConsumeScriptAddress
+    = pure $ P.ConsumeScriptAddress
         (P.Validator $ fromCardanoPlutusScript script)
         (P.Redeemer $ fromCardanoScriptData redeemer)
         (P.Datum $ fromCardanoScriptData datum)
 fromCardanoTxInWitness _ = Nothing
 
+toCardanoTxInWitness :: P.TxInType -> Maybe (C.Witness C.WitCtxTxIn C.AlonzoEra)
+toCardanoTxInWitness P.ConsumePublicKeyAddress = pure (C.KeyWitness C.KeyWitnessForSpending)
+toCardanoTxInWitness
+    (P.ConsumeScriptAddress
+        (P.Validator validator)
+        (P.Redeemer redeemer)
+        (P.Datum datum))
+    = C.ScriptWitness C.ScriptWitnessForSpending <$>
+        (C.PlutusScriptWitness C.PlutusScriptV1InAlonzo C.PlutusScriptV1
+        <$> toCardanoPlutusScript validator
+        <*> pure (C.ScriptDatumForTxIn $ toCardanoScriptData datum)
+        <*> pure (toCardanoScriptData redeemer)
+        <*> toCardanoExecutionUnits validator [datum] -- TODO: is [datum] correct?
+        )
+
 fromCardanoTxOut :: C.TxOut era -> P.TxOut
 fromCardanoTxOut (C.TxOut addr value datumHash) = P.TxOut (fromCardanoAddress addr) (fromCardanoTxOutValue value) (fromCardanoTxOutDatumHash datumHash)
 
+toCardanoTxOut :: P.TxOut -> Maybe (C.TxOut C.AlonzoEra)
+toCardanoTxOut (P.TxOut addr value datumHash) = C.TxOut <$> toCardanoAddress addr <*> toCardanoTxOutValue value <*> toCardanoTxOutDatumHash datumHash
+
 fromCardanoAddress :: C.AddressInEra era -> P.Address
 fromCardanoAddress = fromCardanoAddress -- TODO
 
+toCardanoAddress :: P.Address -> Maybe (C.AddressInEra C.AlonzoEra)
+toCardanoAddress = toCardanoAddress -- TODO
+
 fromCardanoTxOutValue :: C.TxOutValue era -> P.Value
 fromCardanoTxOutValue (C.TxOutAdaOnly _ lovelace) = fromCardanoLovelace lovelace
 fromCardanoTxOutValue (C.TxOutValue _ value)      = fromCardanoValue value
 
+toCardanoTxOutValue :: P.Value -> Maybe (C.TxOutValue C.AlonzoEra)
+toCardanoTxOutValue value = C.TxOutValue C.MultiAssetInAlonzoEra <$> toCardanoValue value
+
 fromCardanoTxOutDatumHash :: C.TxOutDatumHash era -> Maybe P.DatumHash
 fromCardanoTxOutDatumHash C.TxOutDatumHashNone   = Nothing
 fromCardanoTxOutDatumHash (C.TxOutDatumHash _ h) = Just $ P.DatumHash (C.serialiseToRawBytes h)
 
+toCardanoTxOutDatumHash :: Maybe P.DatumHash -> Maybe (C.TxOutDatumHash C.AlonzoEra)
+toCardanoTxOutDatumHash Nothing = pure C.TxOutDatumHashNone
+toCardanoTxOutDatumHash (Just (P.DatumHash bs)) = C.TxOutDatumHash C.ScriptDataInAlonzoEra <$> C.deserialiseFromRawBytes (C.AsHash C.AsScriptData) bs
+
 fromCardanoMintValue :: C.TxMintValue build era -> P.Value
 fromCardanoMintValue C.TxMintNone              = mempty
 fromCardanoMintValue (C.TxMintValue _ value _) = fromCardanoValue value
 
+toCardanoMintValue :: P.Value -> Maybe (C.TxMintValue C.ViewTx C.AlonzoEra)
+toCardanoMintValue value = C.TxMintValue C.MultiAssetInAlonzoEra <$> toCardanoValue value <*> pure C.ViewTx
+
 fromCardanoValue :: C.Value -> P.Value
 fromCardanoValue (C.valueToList -> list) = foldMap toValue list
-  where
-    toValue (C.AdaAssetId, C.Quantity q) = Ada.lovelaceValueOf q
-    toValue (C.AssetId policyId assetName, C.Quantity q)
-      = Value.singleton (fromCardanoPolicyId policyId) (fromCardanoAssetName assetName) q
+    where
+        toValue (C.AdaAssetId, C.Quantity q) = Ada.lovelaceValueOf q
+        toValue (C.AssetId policyId assetName, C.Quantity q)
+            = Value.singleton (fromCardanoPolicyId policyId) (fromCardanoAssetName assetName) q
+
+toCardanoValue :: P.Value -> Maybe C.Value
+toCardanoValue = fmap C.valueFromList . traverse fromValue . Value.flattenValue
+    where
+        fromValue (currencySymbol, tokenName, amount) =
+            (,) <$> (C.AssetId <$> toCardanoPolicyId currencySymbol <*> pure (toCardanoAssetName tokenName)) <*> pure (C.Quantity amount)
 
 fromCardanoPolicyId :: C.PolicyId -> Value.CurrencySymbol
 fromCardanoPolicyId (C.PolicyId scriptHash) = Value.CurrencySymbol (C.serialiseToRawBytes scriptHash)
 
+toCardanoPolicyId :: Value.CurrencySymbol -> Maybe C.PolicyId
+toCardanoPolicyId (Value.CurrencySymbol bs) = C.PolicyId <$> C.deserialiseFromRawBytes C.AsScriptHash bs
+
 fromCardanoAssetName :: C.AssetName -> Value.TokenName
 fromCardanoAssetName (C.AssetName bs) = Value.TokenName bs
 
+toCardanoAssetName :: Value.TokenName -> C.AssetName
+toCardanoAssetName (Value.TokenName bs) = C.AssetName bs
+
 fromCardanoFee :: C.TxFee era -> P.Value
 fromCardanoFee (C.TxFeeImplicit _)          = mempty
 fromCardanoFee (C.TxFeeExplicit _ lovelace) = fromCardanoLovelace lovelace
 
+toCardanoFee :: P.Value -> Maybe (C.TxFee C.AlonzoEra)
+toCardanoFee value = C.TxFeeExplicit C.TxFeesExplicitInAlonzoEra <$> toCardanoLovelace value
+
 fromCardanoLovelace :: C.Lovelace -> P.Value
 fromCardanoLovelace (C.lovelaceToQuantity -> C.Quantity lovelace) = Ada.lovelaceValueOf lovelace
 
+toCardanoLovelace :: P.Value -> Maybe C.Lovelace
+toCardanoLovelace value = if value == Ada.lovelaceValueOf lovelace then pure . C.quantityToLovelace . C.Quantity $ lovelace else Nothing
+    where
+        Ada.Lovelace lovelace = Ada.fromValue value
+
 fromCardanoValidityRange :: (C.TxValidityLowerBound era, C.TxValidityUpperBound era) -> P.SlotRange
 fromCardanoValidityRange (l, u) = P.Interval (fromCardanoValidityLowerBound l) (fromCardanoValidityUpperBound u)
 
+toCardanoValidityRange :: P.SlotRange -> Maybe (C.TxValidityLowerBound C.AlonzoEra, C.TxValidityUpperBound C.AlonzoEra)
+toCardanoValidityRange (P.Interval l u) = (,) <$> toCardanoValidityLowerBound l <*> toCardanoValidityUpperBound u
+
 fromCardanoValidityLowerBound :: C.TxValidityLowerBound era -> P.LowerBound P.Slot
 fromCardanoValidityLowerBound C.TxValidityNoLowerBound = P.LowerBound P.NegInf True
 fromCardanoValidityLowerBound (C.TxValidityLowerBound _ slotNo) = P.LowerBound (P.Finite $ fromCardanoSlotNo slotNo) True -- TODO: inclusive or exclusive?
 
+toCardanoValidityLowerBound :: P.LowerBound P.Slot -> Maybe (C.TxValidityLowerBound C.AlonzoEra)
+toCardanoValidityLowerBound (P.LowerBound P.NegInf _) = pure C.TxValidityNoLowerBound
+toCardanoValidityLowerBound (P.LowerBound (P.Finite slotNo) _) = pure $ C.TxValidityLowerBound C.ValidityLowerBoundInAlonzoEra $ toCardanoSlotNo slotNo -- TODO: inclusive or exclusive?
+toCardanoValidityLowerBound (P.LowerBound P.PosInf _) = Nothing
+
 fromCardanoValidityUpperBound :: C.TxValidityUpperBound era -> P.UpperBound P.Slot
 fromCardanoValidityUpperBound (C.TxValidityNoUpperBound _) = P.UpperBound P.PosInf True
 fromCardanoValidityUpperBound (C.TxValidityUpperBound _ slotNo) = P.UpperBound (P.Finite $ fromCardanoSlotNo slotNo) True -- TODO: inclusive or exclusive?
 
+toCardanoValidityUpperBound :: P.UpperBound P.Slot -> Maybe (C.TxValidityUpperBound C.AlonzoEra)
+toCardanoValidityUpperBound (P.UpperBound P.PosInf _) = pure $ C.TxValidityNoUpperBound C.ValidityNoUpperBoundInAlonzoEra
+toCardanoValidityUpperBound (P.UpperBound (P.Finite slotNo) _) = pure $ C.TxValidityUpperBound C.ValidityUpperBoundInAlonzoEra $ toCardanoSlotNo slotNo -- TODO: inclusive or exclusive?
+toCardanoValidityUpperBound (P.UpperBound P.NegInf _) = Nothing
+
 fromCardanoSlotNo :: C.SlotNo -> P.Slot
 fromCardanoSlotNo (C.SlotNo w64) = P.Slot (toInteger w64)
 
+toCardanoSlotNo :: P.Slot -> C.SlotNo
+toCardanoSlotNo (P.Slot i) = C.SlotNo (fromInteger i)
+
 fromCardanoAuxScriptData :: C.TxAuxScriptData era -> [P.Datum]
 fromCardanoAuxScriptData C.TxAuxScriptDataNone            = []
 fromCardanoAuxScriptData (C.TxAuxScriptData _ scriptData) = fmap (P.Datum . fromCardanoScriptData) scriptData
 
--- TODO: replace with C.toPlutusData, but it is not exported
+toCardanoAuxScriptData :: [P.Datum] -> C.TxAuxScriptData C.AlonzoEra
+toCardanoAuxScriptData = C.TxAuxScriptData C.ScriptDataInAlonzoEra . fmap (toCardanoScriptData . P.getDatum)
+
 fromCardanoScriptData :: C.ScriptData -> Data.Data
-fromCardanoScriptData (C.ScriptDataConstructor i args) = Data.Constr i $ fmap fromCardanoScriptData args
-fromCardanoScriptData (C.ScriptDataMap kvs) = Data.Map $ fmap (bimap fromCardanoScriptData fromCardanoScriptData) kvs
-fromCardanoScriptData (C.ScriptDataList xs) = Data.List $ fmap fromCardanoScriptData xs
-fromCardanoScriptData (C.ScriptDataNumber i) = Data.I i
-fromCardanoScriptData (C.ScriptDataBytes bs) = Data.B bs
+fromCardanoScriptData = C.toPlutusData
+
+toCardanoScriptData :: Data.Data -> C.ScriptData
+toCardanoScriptData = C.fromPlutusData
 
 fromCardanoKeyWitnesses :: [C.KeyWitness era] -> Map.Map P.PubKey P.Signature
 fromCardanoKeyWitnesses = fromCardanoKeyWitnesses -- TODO
@@ -137,13 +232,28 @@ fromCardanoTxAuxScripts :: C.TxAuxScripts era -> Set.Set P.MonetaryPolicy
 fromCardanoTxAuxScripts C.TxAuxScriptsNone = mempty
 fromCardanoTxAuxScripts (C.TxAuxScripts _ scripts) = Set.fromList . mapMaybe (fmap P.MonetaryPolicy . fromCardanoScriptInEra) $ scripts
 
+toCardanoTxAuxScripts :: Set.Set P.MonetaryPolicy -> Maybe (C.TxAuxScripts C.AlonzoEra)
+toCardanoTxAuxScripts = fmap (C.TxAuxScripts C.AuxScriptsInAlonzoEra) . traverse (toCardanoScriptInEra . P.getMonetaryPolicy) . Set.toList
+
 fromCardanoScriptInEra :: C.ScriptInEra era -> Maybe P.Script
 fromCardanoScriptInEra (C.ScriptInEra C.PlutusScriptV1InAlonzo (C.PlutusScript C.PlutusScriptV1 script)) =
-  Just $ fromCardanoPlutusScript script
-fromCardanoScriptInEra _ = Nothing -- TODO: throw error, or maybe SimpleScripts actually are supported?
+    pure $ fromCardanoPlutusScript script
+fromCardanoScriptInEra _ = Nothing
+
+toCardanoScriptInEra :: P.Script -> Maybe (C.ScriptInEra C.AlonzoEra)
+toCardanoScriptInEra script = C.ScriptInEra C.PlutusScriptV1InAlonzo . C.PlutusScript C.PlutusScriptV1 <$> toCardanoPlutusScript script
+
+fromCardanoPlutusScript :: C.HasTypeProxy lang => C.PlutusScript lang -> P.Script
+fromCardanoPlutusScript = Codec.deserialise . BSL.fromStrict . C.serialiseToRawBytes
 
-fromCardanoPlutusScript :: C.PlutusScript lang -> P.Script
-fromCardanoPlutusScript = deserialise . BSL.fromStrict . C.serialiseToRawBytes
+toCardanoPlutusScript :: P.Script -> Maybe (C.PlutusScript C.PlutusScriptV1)
+toCardanoPlutusScript = C.deserialiseFromRawBytes (C.AsPlutusScript C.AsPlutusScriptV1) . BSL.toStrict . Codec.serialise
 
--- TODO: Conversion functions between our Tx types and those from Cardano.Api
--- https://input-output-hk.github.io/cardano-node/cardano-api/Cardano-Api.html
+toCardanoExecutionUnits :: P.Script -> [Data.Data] -> Maybe C.ExecutionUnits
+toCardanoExecutionUnits script datum = do
+    cmp <- Api.defaultCostModelParams
+    let apiScript = BSS.toShort . BSL.toStrict $ Codec.serialise script
+    case Api.evaluateScriptCounting Api.Quiet cmp apiScript datum of
+        (_, Left _) -> Nothing
+        (_, Right (Api.ExBudget (Api.ExCPU cpu) (Api.ExMemory memory))) ->
+            pure $ C.ExecutionUnits (fromInteger $ toInteger cpu) (fromInteger $ toInteger memory)