Rewrite deserialiseFromCBOR using asum with Alternative Maybe

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) =

cardano-api/test/cardano-api-test/Test/Cardano/Api/Experimental.hs

@@ -46,6 +46,7 @@ import Data.Time qualified as Time
 import Data.Time.Clock.POSIX qualified as Time
 import Lens.Micro
 
+import Test.Gen.Cardano.Api.Experimental (genAnyScript)
 import Test.Gen.Cardano.Api.Typed (genAddressInEra, genTx, genTxIn)
 
 import Hedgehog (Gen, Property)
@@ -80,6 +81,15 @@ tests =
     , testProperty
         "Roundtrip SerialiseAsRawBytes SignedTx"
         prop_roundtrip_serialise_as_raw_bytes_signed_tx
+    , testGroup
+        "SerialiseAsCBOR AnyScript"
+        [ testProperty
+            "Roundtrip serialiseToCBOR/deserialiseFromCBOR AnyScript"
+            prop_roundtrip_cbor_any_script
+        , testProperty
+            "Deserialising garbage bytes returns Left"
+            prop_deserialise_garbage_bytes_returns_left
+        ]
     , testGroup
         "calcMinFeeRecursive"
         [ testProperty
@@ -109,6 +119,21 @@ tests =
         ]
     ]
 
+prop_roundtrip_cbor_any_script :: Property
+prop_roundtrip_cbor_any_script = H.property $ do
+  script <- H.forAll genAnyScript
+  H.tripping script Api.serialiseToCBOR (Api.deserialiseFromCBOR Exp.AsAnyScript)
+
+-- | Deserialising random garbage bytes should always return 'Left'.
+prop_deserialise_garbage_bytes_returns_left :: Property
+prop_deserialise_garbage_bytes_returns_left = H.property $ do
+  garbage <- H.forAll $ Gen.bytes (Range.linear 0 128)
+  case Api.deserialiseFromCBOR
+    (Exp.AsAnyScript :: Exp.AsType (Exp.AnyScript (Exp.LedgerEra Exp.ConwayEra)))
+    garbage of
+    Left _ -> H.success
+    Right _ -> H.annotate "Expected deserialisation failure but got Right" >> H.failure
+
 prop_created_transaction_with_both_apis_are_the_same :: Property
 prop_created_transaction_with_both_apis_are_the_same = H.propertyOnce $ do
   let era = Exp.ConwayEra

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

@@ -11,7 +11,6 @@ where
 import Cardano.Api (AlonzoEraOnwards (..))
 import Cardano.Api qualified as Api
 import Cardano.Api.Experimental
-import Cardano.Api.Experimental.AnyScript
 import Cardano.Api.Experimental.AnyScriptWitness
 import Cardano.Api.Experimental.Plutus hiding (AnyPlutusScript (..))
 import Cardano.Api.Experimental.Tx qualified as Exp