Merge pull request #1122 from IntersectMBO/jordan/1088-serialise-as-cbor-any-simple-script

Implement SerialiseAsCBOR and Eq for AnyScript era

Author: Jimbo4350

cardano-api/gen/Test/Gen/Cardano/Api/Experimental.hs

@@ -1,16 +1,19 @@
 {-# LANGUAGE DataKinds #-}
 
 module Test.Gen.Cardano.Api.Experimental
-  ( genScriptWitnessedTxCertificates
+  ( genAnyScript
+  , genScriptWitnessedTxCertificates
   , genScriptWitnessedTxIn
   , genScriptWitnessedTxMintValue
   , genScriptWitnessedTxProposals
   , genScriptWitnesssedTxVotingProcedures
   , genScriptWitnessedTxWithdrawals
+  , genSimpleScriptInEra
   )
 where
 
 import Cardano.Api (TxIn)
+import Cardano.Api qualified as Old
 import Cardano.Api.Experimental
 import Cardano.Api.Experimental.AnyScriptWitness
 import Cardano.Api.Experimental.Tx
@@ -19,7 +22,13 @@ import Cardano.Api.Ledger qualified as L
 import Data.Map.Ordered.Strict qualified as OMap
 import Data.Typeable
 
-import Test.Gen.Cardano.Api.Typed (genExecutionUnits, genHashableScriptData, genTxIn)
+import Test.Gen.Cardano.Api.Typed
+  ( genExecutionUnits
+  , genHashableScriptData
+  , genPlutusScriptInEra
+  , genSimpleScript
+  , genTxIn
+  )
 
 import Hedgehog (Gen)
 import Hedgehog.Gen qualified as Gen
@@ -88,6 +97,19 @@ genAnyPlutusScriptWitnessV4 :: Gen (AnyWitness era)
 genAnyPlutusScriptWitnessV4 =
   genAnyPlutusScriptWitness L.SPlutusV4
 
+genSimpleScriptInEra :: Gen (SimpleScript (LedgerEra ConwayEra))
+genSimpleScriptInEra = do
+  oldSimpleScript <- genSimpleScript
+  let timelock = Old.toAllegraTimelock oldSimpleScript
+  return $ SimpleScript timelock
+
+genAnyScript :: Gen (AnyScript (LedgerEra ConwayEra))
+genAnyScript =
+  Gen.choice
+    [ AnySimpleScript <$> genSimpleScriptInEra
+    , AnyPlutusScript <$> genPlutusScriptInEra
+    ]
+
 genAnySimpleScriptWitness :: Gen (SimpleScriptOrReferenceInput era)
 genAnySimpleScriptWitness = SReferenceScript <$> genTxIn
 

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

@@ -50,6 +50,12 @@ module Cardano.Api.Experimental
   , Witnessable (..)
   , WitnessableItem (..)
 
+    -- ** AnyScript related
+  , AnyScript (..)
+  , deserialiseAnyPlutusScriptOfLanguage
+  , deserialiseAnySimpleScript
+  , hashAnyScript
+
     -- ** Simple script related
   , SimpleScript (..)
   , SimpleScriptOrReferenceInput (..)
@@ -98,6 +104,7 @@ module Cardano.Api.Experimental
   )
 where
 
+import Cardano.Api.Experimental.AnyScript
 import Cardano.Api.Experimental.Certificate
 import Cardano.Api.Experimental.Era
 import Cardano.Api.Experimental.Plutus.Internal.IndexedPlutusScriptWitness

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

@@ -1,12 +1,15 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Cardano.Api.Experimental.AnyScript
   ( AnyScript (..)
+  , AsType (..)
   , deserialiseAnyPlutusScriptOfLanguage
   , deserialiseAnySimpleScript
   , hashAnyScript
@@ -18,16 +21,76 @@ import Cardano.Api.Experimental.Plutus.Internal.Script hiding (AnyPlutusScript)
 import Cardano.Api.Experimental.Simple.Script
 import Cardano.Api.HasTypeProxy
 import Cardano.Api.Ledger.Internal.Reexport qualified as L
+import Cardano.Api.Serialise.Cbor
 
-import Cardano.Binary qualified as CBOR
+import Cardano.Ledger.Binary qualified as CBOR
 import Cardano.Ledger.Core qualified as L
 import Cardano.Ledger.Plutus.Language qualified as Plutus
 
 import Data.ByteString qualified as BS
+import Data.Either.Combinators (maybeToRight, rightToMaybe)
+import Data.Foldable (asum)
+import Data.Type.Equality ((:~:) (..))
+import Data.Typeable (Typeable, eqT)
 
 data AnyScript era where
   AnySimpleScript :: SimpleScript era -> AnyScript era
-  AnyPlutusScript :: Plutus.PlutusLanguage lang => PlutusScriptInEra lang era -> AnyScript era
+  AnyPlutusScript
+    :: (Plutus.PlutusLanguage lang, Typeable lang) => PlutusScriptInEra lang era -> AnyScript era
+
+instance L.Era era => HasTypeProxy (AnyScript era) where
+  data AsType (AnyScript era) = AsAnyScript
+  proxyToAsType _ = AsAnyScript
+
+instance Show (AnyScript era) where
+  show (AnySimpleScript ss) = "AnySimpleScript " ++ show ss
+  show (AnyPlutusScript ps) = "AnyPlutusScript " ++ show ps
+
+instance Eq (AnyScript era) where
+  AnySimpleScript s1 == AnySimpleScript s2 = s1 == s2
+  AnyPlutusScript (ps1 :: PlutusScriptInEra lang1 era) == AnyPlutusScript (ps2 :: PlutusScriptInEra lang2 era) =
+    case eqT @lang1 @lang2 of
+      Just Refl -> ps1 == ps2
+      Nothing -> False
+  _ == _ = False
+
+instance
+  L.AlonzoEraScript era
+  => SerialiseAsCBOR (AnyScript era)
+  where
+  serialiseToCBOR (AnySimpleScript (SimpleScript ns)) =
+    L.serialize' (L.eraProtVerHigh @era) (L.fromNativeScript ns :: L.Script era)
+  serialiseToCBOR (AnyPlutusScript ps) =
+    L.serialize' (L.eraProtVerHigh @era) (plutusScriptInEraToScript ps)
+
+  deserialiseFromCBOR _ bs = do
+    script <- decodeScript
+    maybeToRight noParseError $
+      asum
+        [ tryNativeScript script
+        , tryPlutusScript script
+        ]
+   where
+    decodeScript :: Either CBOR.DecoderError (L.Script era)
+    decodeScript = do
+      r <- CBOR.runAnnotator <$> CBOR.decodeFull' (L.eraProtVerHigh @era) bs
+      return $ r $ CBOR.Full $ BS.fromStrict bs
+
+    tryNativeScript :: L.Script era -> Maybe (AnyScript era)
+    tryNativeScript = fmap (AnySimpleScript . SimpleScript) . L.getNativeScript
+
+    tryPlutusScript :: L.Script era -> Maybe (AnyScript era)
+    tryPlutusScript script = do
+      ps <- L.toPlutusScript script
+      L.withPlutusScript ps $ \(plutus :: Plutus.Plutus l) ->
+        AnyPlutusScript . PlutusScriptInEra
+          <$> rightToMaybe (Plutus.decodePlutusRunnable (L.eraProtVerHigh @era) plutus)
+
+    noParseError :: CBOR.DecoderError
+    noParseError =
+      CBOR.DecoderErrorCustom
+        "AnyScript"
+        "Decoded Script era is neither a NativeScript nor a PlutusScript"
 
 hashAnyScript :: forall era. IsEra era => AnyScript (LedgerEra era) -> L.ScriptHash
 hashAnyScript (AnySimpleScript ss) =