Merge pull request #1156 from IntersectMBO/jordan/1240-has-text-envelope-any-plutus-script

Add text envelope serialisation for AnyPlutusScript

Author: Jimbo4350

cardano-api/src/Cardano/Api/Experimental.hs

@@ -67,6 +67,8 @@ module Cardano.Api.Experimental
     -- ** Plutus related
   , PlutusScriptInEra (..)
   , PlutusScriptOrReferenceInput (..)
+  , serialiseAnyPlutusScriptToTextEnvelope
+  , deserialiseAnyPlutusScriptFromTextEnvelope
   , IndexedPlutusScriptWitness (..)
   , PlutusScriptPurpose (..)
   , PlutusScriptDatum (..)

cardano-api/src/Cardano/Api/Experimental/Plutus.hs

@@ -2,6 +2,8 @@ module Cardano.Api.Experimental.Plutus
   ( -- * Plutus Script
     AnyPlutusScript (..)
   , decodeAnyPlutusScript
+  , serialiseAnyPlutusScriptToTextEnvelope
+  , deserialiseAnyPlutusScriptFromTextEnvelope
   , PlutusScriptInEra (..)
   , AnyPlutusScriptLanguage (..)
   , deserialisePlutusScriptInEra

cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/Script.hs

@@ -11,6 +11,8 @@
 module Cardano.Api.Experimental.Plutus.Internal.Script
   ( AnyPlutusScript (..)
   , decodeAnyPlutusScript
+  , serialiseAnyPlutusScriptToTextEnvelope
+  , deserialiseAnyPlutusScriptFromTextEnvelope
   , AnyPlutusScriptLanguage (..)
   , PlutusScriptInEra (..)
   , PlutusScriptOrReferenceInput (..)
@@ -115,8 +117,11 @@ instance
   )
   => SerialiseAsCBOR (PlutusScriptInEra (lang :: L.Language) era)
   where
+  -- The 'PlutusBinary' stored in the 'PlutusRunnable' already contains
+  -- CBOR-wrapped Flat-encoded UPLC bytes (see 'Cardano.Ledger.Plutus.Language'),
+  -- so we extract them directly rather than re-encoding with 'L.serialize''.
   serialiseToCBOR (PlutusScriptInEra s) =
-    L.serialize' (L.eraProtVerHigh @era) s
+    SBS.fromShort . L.unPlutusBinary . L.plutusBinary $ L.plutusFromRunnable s
 
   deserialiseFromCBOR _ bs = do
     let v = L.eraProtVerHigh @era
@@ -179,6 +184,15 @@ data AnyPlutusScript era where
     :: (L.Era era, Typeable lang, L.PlutusLanguage lang)
     => PlutusScriptInEra lang era -> AnyPlutusScript era
 
+instance Show (AnyPlutusScript era) where
+  show (AnyPlutusScript ps) = "AnyPlutusScript " ++ show ps
+
+instance Eq (AnyPlutusScript era) where
+  AnyPlutusScript (ps1 :: PlutusScriptInEra lang1 era) == AnyPlutusScript (ps2 :: PlutusScriptInEra lang2 era) =
+    case eqT @lang1 @lang2 of
+      Just Refl -> ps1 == ps2
+      Nothing -> False
+
 decodeAnyPlutusScript
   :: L.Era era
   => ByteString
@@ -201,3 +215,32 @@ data AnyPlutusScriptLanguage where
   AnyPlutusScriptLanguage
     :: L.PlutusLanguage lang
     => L.SLanguage lang -> AnyPlutusScriptLanguage
+
+-- | Serialise an 'AnyPlutusScript' to a 'TextEnvelope'. The text envelope type
+-- is determined by the Plutus language version of the script.
+serialiseAnyPlutusScriptToTextEnvelope
+  :: Maybe TextEnvelopeDescr -> AnyPlutusScript era -> TextEnvelope
+serialiseAnyPlutusScriptToTextEnvelope mbDescr (AnyPlutusScript script) =
+  obtainLangConstraints (plutusScriptInEraSLanguage script) $
+    serialiseToTextEnvelope mbDescr script
+
+-- | Deserialise an 'AnyPlutusScript' from a 'TextEnvelope'. The text envelope type
+-- is matched against all known Plutus language versions derived from
+-- 'Plutus.nonNativeLanguages', so new language versions are picked up automatically.
+deserialiseAnyPlutusScriptFromTextEnvelope
+  :: forall era
+   . L.Era era
+  => TextEnvelope
+  -> Either TextEnvelopeError (AnyPlutusScript era)
+deserialiseAnyPlutusScriptFromTextEnvelope =
+  deserialiseFromTextEnvelopeAnyOf textEnvTypes
+ where
+  textEnvTypes :: [FromSomeType HasTextEnvelope (AnyPlutusScript era)]
+  textEnvTypes =
+    map
+      ( \l ->
+          Plutus.withSLanguage l $ \(slang :: Plutus.SLanguage l) ->
+            obtainLangConstraints slang $
+              FromSomeType (asType @(PlutusScriptInEra l era)) AnyPlutusScript
+      )
+      Plutus.nonNativeLanguages

cardano-api/test/cardano-api-test/Test/Cardano/Api/Transaction/Body/Plutus/Scripts.hs

@@ -8,22 +8,26 @@ module Test.Cardano.Api.Transaction.Body.Plutus.Scripts
   )
 where
 
-import Cardano.Api (AlonzoEraOnwards (..))
+import Cardano.Api (AlonzoEraOnwards (..), proxyToAsType)
 import Cardano.Api qualified as Api
 import Cardano.Api.Experimental
 import Cardano.Api.Experimental.AnyScriptWitness
 import Cardano.Api.Experimental.Plutus hiding (AnyPlutusScript (..))
+import Cardano.Api.Experimental.Plutus qualified as Plutus
 import Cardano.Api.Experimental.Tx qualified as Exp
 import Cardano.Api.Ledger qualified as L
+import Cardano.Api.Serialise.Cbor (SerialiseAsCBOR (..))
 
 import Cardano.Ledger.Conway qualified as L
 import Cardano.Ledger.Core qualified as L
+import Cardano.Ledger.Plutus.Language qualified as L
 
 import Prelude
 
 import Data.Function
 import Data.List qualified as List
 import Data.Map.Strict qualified as Map
+import Data.Proxy (Proxy (..))
 
 import Test.Gen.Cardano.Api.Experimental qualified as Exp
 import Test.Gen.Cardano.Api.Typed
@@ -55,6 +59,23 @@ prop_compare_plutus_script_hashes = property $ do
 
   hash === anyScriptHash
 
+prop_roundtrip_plutus_script_in_era_cbor :: Property
+prop_roundtrip_plutus_script_in_era_cbor = property $ do
+  scriptInEra <- forAll genPlutusScriptInEra
+  tripping
+    scriptInEra
+    serialiseToCBOR
+    (deserialiseFromCBOR (proxyToAsType (Proxy @(PlutusScriptInEra L.PlutusV3 (LedgerEra ConwayEra)))))
+
+prop_roundtrip_any_plutus_script_text_envelope :: Property
+prop_roundtrip_any_plutus_script_text_envelope = property $ do
+  scriptInEra <- forAll genPlutusScriptInEra
+  let anyScript = Plutus.AnyPlutusScript scriptInEra
+  tripping
+    anyScript
+    (serialiseAnyPlutusScriptToTextEnvelope Nothing)
+    (deserialiseAnyPlutusScriptFromTextEnvelope @(LedgerEra ConwayEra))
+
 -- | This property checks that the redeemer pointer map is constructed correctly.
 -- Previously identical script purposes were being created and overwriting each other
 -- in the redeemer pointer map.
@@ -214,6 +235,12 @@ tests =
   testGroup
     "Test.Cardano.Api.Transaction.Body.Plutus.Scripts"
     [ testProperty "prop_compare_plutus_script_hashes" prop_compare_plutus_script_hashes
+    , testProperty
+        "prop_roundtrip_plutus_script_in_era_cbor"
+        prop_roundtrip_plutus_script_in_era_cbor
+    , testProperty
+        "prop_roundtrip_any_plutus_script_text_envelope"
+        prop_roundtrip_any_plutus_script_text_envelope
     , testProperty
         "prop_extractAllIndexedPlutusScriptWitnesses"
         prop_extractAllIndexedPlutusScriptWitnesses