{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.Hedgehog.Roundtrip.CBOR
  ( decodeOnlyPlutusScriptBytes
  , assertValidPlutusScriptBytesExperimental
  , trippingCbor
  )
where

import Cardano.Api
import Cardano.Api.Experimental qualified as Exp
import Cardano.Api.Experimental.Plutus qualified as Exp
import Cardano.Api.Ledger qualified as L

import Cardano.Ledger.Core qualified as Ledger
import Cardano.Ledger.Plutus.Language qualified as Plutus

import Data.ByteString (ByteString)
import Data.ByteString.Short qualified as SBS
import GHC.Stack (HasCallStack)
import GHC.Stack qualified as GHC

import Hedgehog qualified as H
import Hedgehog.Internal.Property (failWith)

-- | Assert that CBOR serialisation and deserialisation roundtrips.
trippingCbor
  :: ()
  => HasCallStack
  => H.MonadTest m
  => Show a
  => Eq a
  => SerialiseAsCBOR a
  => AsType a
  -> a
  -> m ()
trippingCbor :: forall (m :: * -> *) a.
(HasCallStack, MonadTest m, Show a, Eq a, SerialiseAsCBOR a) =>
AsType a -> a -> m ()
trippingCbor AsType a
typeProxy a
v =
  (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$
    a
-> (a -> ByteString)
-> (ByteString -> Either DecoderError a)
-> m ()
forall (m :: * -> *) (f :: * -> *) b a.
(MonadTest m, Applicative f, Show b, Show (f a), Eq (f a),
 HasCallStack) =>
a -> (a -> b) -> (b -> f a) -> m ()
H.tripping a
v a -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR (AsType a -> ByteString -> Either DecoderError a
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR AsType a
typeProxy)

-- | We need to confirm the existing 'SerialiseAsCBOR' instance for 'Script lang'
-- no longer double serializes scripts but is backwards compatible with
-- doubly serialized scripts.
--
-- We would also like to check that the deserialized bytes is a valid
-- plutus script. We can do this by using the 'SerialiseAsCBOR' instance for
-- 'PlutusScriptInEra'.
--
-- We will check the following:
-- 1. Deserializing double encoded script bytes and "normal" script bytes
--    decode to the same byte sequence.
-- 2. The resulting bytes are both valid plutus scripts (via 'PlutusScriptInEra')
--
-- If these two properties hold we can be sure that existing double encoded scripts
-- will deserialize correctly and newly created scripts will also deserialize correctly.
decodeOnlyPlutusScriptBytes
  :: forall era lang m
   . HasCallStack
  => Ledger.Era (ShelleyLedgerEra era)
  => H.MonadTest m
  => Plutus.PlutusLanguage (ToLedgerPlutusLanguage lang)
  => IsPlutusScriptLanguage lang
  => HasTypeProxy era
  => ShelleyBasedEra era
  -> PlutusScriptVersion lang
  -> ByteString
  -- ^ This can be a double encoded or "normal" plutus script
  -> AsType (Script lang)
  -> m ()
decodeOnlyPlutusScriptBytes :: forall era lang (m :: * -> *).
(HasCallStack, Era (ShelleyLedgerEra era), MonadTest m,
 PlutusLanguage (ToLedgerPlutusLanguage lang),
 IsPlutusScriptLanguage lang, HasTypeProxy era) =>
ShelleyBasedEra era
-> PlutusScriptVersion lang
-> ByteString
-> AsType (Script lang)
-> m ()
decodeOnlyPlutusScriptBytes ShelleyBasedEra era
_ PlutusScriptVersion lang
_ ByteString
scriptBytes AsType (Script lang)
typeProxy = do
  -- Decode a plutus script (double wrapped or "normal" plutus script) with the existing SerialiseAsCBOR instance for
  -- 'Script lang'. This should produce plutus script bytes that are not double encoded.
  (PlutusScriptSerialised expectedToBeValidScriptBytes) <- case AsType (Script lang)
-> ByteString -> Either DecoderError (Script lang)
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR AsType (Script lang)
typeProxy ByteString
scriptBytes of
    Left DecoderError
e -> Maybe Diff -> [Char] -> m (PlutusScript lang)
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> [Char] -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing ([Char] -> m (PlutusScript lang))
-> [Char] -> m (PlutusScript lang)
forall a b. (a -> b) -> a -> b
$ [Char]
"Plutus lang: Error decoding script bytes: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DecoderError -> [Char]
forall a. Show a => a -> [Char]
show DecoderError
e
    Right (SimpleScript SimpleScript
_) -> Maybe Diff -> [Char] -> m (PlutusScript lang)
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> [Char] -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing [Char]
"Simple script found. Should be impossible."
    Right (PlutusScript PlutusScriptVersion lang
_ PlutusScript lang
plutusScript) -> PlutusScript lang -> m (PlutusScript lang)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PlutusScript lang
plutusScript

  -- We check that the script is "runnable" and of the expected language via the
  -- 'PlutusScriptInEra era lang' SerialiseAsCBOR instance.
  (PlutusScriptSerialised confirmedToBeValidScriptBytes) <-
    case deserialiseFromCBOR (AsPlutusScriptInEra @era (proxyToAsType (Proxy :: Proxy lang))) $
      SBS.fromShort expectedToBeValidScriptBytes of
      Left DecoderError
e -> Maybe Diff -> [Char] -> m (PlutusScript lang)
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> [Char] -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing ([Char] -> m (PlutusScript lang))
-> [Char] -> m (PlutusScript lang)
forall a b. (a -> b) -> a -> b
$ [Char]
"PlutusScriptInEra: Error decoding plutus script bytes: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DecoderError -> [Char]
forall a. Show a => a -> [Char]
show DecoderError
e
      Right (PlutusScriptInEra PlutusScript lang
p) -> PlutusScript lang -> m (PlutusScript lang)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PlutusScript lang
p

  -- We also confirm that PlutusScriptInEra SerialiseAsCBOR instance can handle double encoded
  -- plutus scripts.
  case deserialiseFromCBOR (AsPlutusScriptInEra @era (proxyToAsType (Proxy :: Proxy lang))) scriptBytes of
    Left DecoderError
e -> Maybe Diff -> [Char] -> m ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> [Char] -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"PlutusScriptInEra: Error decoding double wrapped bytes: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DecoderError -> [Char]
forall a. Show a => a -> [Char]
show DecoderError
e
    Right (PlutusScriptInEra (PlutusScriptSerialised ShortByteString
shouldAlsoBeValidScriptBytes)) -> do
      ShortByteString
confirmedToBeValidScriptBytes ShortByteString -> ShortByteString -> m ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
H.=== ShortByteString
shouldAlsoBeValidScriptBytes

  -- If we have fixed the double encoding issue, the bytes produced
  -- should be the same.
  expectedToBeValidScriptBytes H.=== confirmedToBeValidScriptBytes

assertValidPlutusScriptBytesExperimental
  :: forall era lang m
   . H.MonadTest m
  => HasTypeProxy (Plutus.SLanguage lang)
  => Plutus.PlutusLanguage lang
  => Exp.Era era
  -> ByteString
  -- ^ This can be a double encoded or "normal" plutus script
  -> L.SLanguage lang
  -> m ()
assertValidPlutusScriptBytesExperimental :: forall era (lang :: Language) (m :: * -> *).
(MonadTest m, HasTypeProxy (SLanguage lang),
 PlutusLanguage lang) =>
Era era -> ByteString -> SLanguage lang -> m ()
assertValidPlutusScriptBytesExperimental Era era
era ByteString
scriptBytes SLanguage lang
lang = do
  -- Decode a plutus script (double wrapped or "normal" plutus script) with the existing SerialiseAsCBOR instance for
  -- 'Script lang'. This should produce plutus script bytes that are not double encoded.
  case Era era
-> (EraCommonConstraints era =>
    Either DecoderError (PlutusScriptInEra lang (LedgerEra era)))
-> Either DecoderError (PlutusScriptInEra lang (LedgerEra era))
forall era a. Era era -> (EraCommonConstraints era => a) -> a
Exp.obtainCommonConstraints Era era
era ((EraCommonConstraints era =>
  Either DecoderError (PlutusScriptInEra lang (LedgerEra era)))
 -> Either DecoderError (PlutusScriptInEra lang (LedgerEra era)))
-> (EraCommonConstraints era =>
    Either DecoderError (PlutusScriptInEra lang (LedgerEra era)))
-> Either DecoderError (PlutusScriptInEra lang (LedgerEra era))
forall a b. (a -> b) -> a -> b
$ SLanguage lang
-> ByteString
-> Either DecoderError (PlutusScriptInEra lang (LedgerEra era))
forall era (lang :: Language).
(PlutusLanguage lang, HasTypeProxy (SLanguage lang), Era era) =>
SLanguage lang
-> ByteString -> Either DecoderError (PlutusScriptInEra lang era)
Exp.deserialisePlutusScriptInEra SLanguage lang
lang ByteString
scriptBytes
         :: Either DecoderError (Exp.PlutusScriptInEra lang (Exp.LedgerEra era)) of
    Left DecoderError
e -> Maybe Diff -> [Char] -> m ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> [Char] -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Plutus lang: Error decoding script bytes: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DecoderError -> [Char]
forall a. Show a => a -> [Char]
show (DecoderError
e :: DecoderError)
    Right (Exp.PlutusScriptInEra{}) -> m ()
forall (m :: * -> *). MonadTest m => m ()
H.success