{-# OPTIONS_GHC -Wno-orphans #-}

module Hydra.Cardano.Api.PlutusScript where

import Hydra.Cardano.Api.Prelude

import Cardano.Ledger.Alonzo.Scripts qualified as Ledger
import Cardano.Ledger.Plutus.Language qualified as Ledger
import Data.ByteString.Short qualified as SBS
import PlutusLedgerApi.Common qualified as Plutus
import Test.QuickCheck (listOf)

-- * Type Conversions

-- | Convert a cardano-ledger 'Script' into a cardano-api 'PlutusScript'
--
-- NOTE: This function is unsafe in two manners:
--
-- (a) If the given script is a timelock script, it throws an impure exception;
-- (b) If the given script is in a wrong language, it silently coerces it.
fromLedgerScript ::
  ( HasCallStack
  , Ledger.AlonzoEraScript era
  ) =>
  Ledger.AlonzoScript era ->
  PlutusScript lang
fromLedgerScript :: forall era lang.
(HasCallStack, AlonzoEraScript era) =>
AlonzoScript era -> PlutusScript lang
fromLedgerScript = \case
  Ledger.TimelockScript{} -> [Char] -> PlutusScript lang
forall a. HasCallStack => [Char] -> a
error [Char]
"fromLedgerScript: TimelockScript"
  Ledger.PlutusScript PlutusScript era
x -> PlutusScript era
-> (forall (l :: Language).
    PlutusLanguage l =>
    Plutus l -> PlutusScript lang)
-> PlutusScript lang
forall era a.
AlonzoEraScript era =>
PlutusScript era
-> (forall (l :: Language). PlutusLanguage l => Plutus l -> a) -> a
forall a.
PlutusScript era
-> (forall (l :: Language). PlutusLanguage l => Plutus l -> a) -> a
Ledger.withPlutusScript PlutusScript era
x (\(Ledger.Plutus (Ledger.PlutusBinary ShortByteString
bytes)) -> ShortByteString -> PlutusScript lang
forall lang. ShortByteString -> PlutusScript lang
PlutusScriptSerialised ShortByteString
bytes)

-- | Convert a serialized plutus script into a cardano-api 'PlutusScript'.
fromPlutusScript :: Plutus.SerialisedScript -> PlutusScript lang
fromPlutusScript :: forall lang. ShortByteString -> PlutusScript lang
fromPlutusScript =
  ShortByteString -> PlutusScript lang
forall lang. ShortByteString -> PlutusScript lang
PlutusScriptSerialised

-- * Orphans

instance IsPlutusScriptLanguage lang => ToJSON (PlutusScript lang) where
  toJSON :: PlutusScript lang -> Value
toJSON = TextEnvelope -> Value
forall a. ToJSON a => a -> Value
toJSON (TextEnvelope -> Value)
-> (PlutusScript lang -> TextEnvelope)
-> PlutusScript lang
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe TextEnvelopeDescr -> PlutusScript lang -> TextEnvelope
forall a.
HasTextEnvelope a =>
Maybe TextEnvelopeDescr -> a -> TextEnvelope
serialiseToTextEnvelope Maybe TextEnvelopeDescr
forall a. Maybe a
Nothing

instance IsPlutusScriptLanguage lang => FromJSON (PlutusScript lang) where
  parseJSON :: Value -> Parser (PlutusScript lang)
parseJSON Value
v = do
    TextEnvelope
env <- Value -> Parser TextEnvelope
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    case AsType (PlutusScript lang)
-> TextEnvelope -> Either TextEnvelopeError (PlutusScript lang)
forall a.
HasTextEnvelope a =>
AsType a -> TextEnvelope -> Either TextEnvelopeError a
deserialiseFromTextEnvelope (Proxy (PlutusScript lang) -> AsType (PlutusScript lang)
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType Proxy (PlutusScript lang)
forall {k} (t :: k). Proxy t
Proxy) TextEnvelope
env of
      Left TextEnvelopeError
e -> [Char] -> Parser (PlutusScript lang)
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser (PlutusScript lang))
-> [Char] -> Parser (PlutusScript lang)
forall a b. (a -> b) -> a -> b
$ TextEnvelopeError -> [Char]
forall a. Show a => a -> [Char]
show TextEnvelopeError
e
      Right PlutusScript lang
a -> PlutusScript lang -> Parser (PlutusScript lang)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PlutusScript lang
a

instance Arbitrary (PlutusScript lang) where
  arbitrary :: Gen (PlutusScript lang)
arbitrary =
    ShortByteString -> PlutusScript lang
forall lang. ShortByteString -> PlutusScript lang
PlutusScriptSerialised (ShortByteString -> PlutusScript lang)
-> ([Word8] -> ShortByteString) -> [Word8] -> PlutusScript lang
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ShortByteString
SBS.pack ([Word8] -> PlutusScript lang)
-> Gen [Word8] -> Gen (PlutusScript lang)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word8 -> Gen [Word8]
forall a. Gen a -> Gen [a]
listOf Gen Word8
forall a. Arbitrary a => Gen a
arbitrary