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

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

import Cardano.Api

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)

{- HLINT ignore "Use camelCase" -}

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