{-# OPTIONS_GHC -Wno-orphans #-}

module Hydra.Cardano.Api.ScriptData where

import Hydra.Cardano.Api.Prelude hiding (left)

import Cardano.Ledger.Alonzo.TxWits qualified as Ledger
import Cardano.Ledger.Era qualified as Ledger
import Cardano.Ledger.Plutus.Data qualified as Ledger
import Codec.Serialise (deserialiseOrFail, serialise)
import Control.Arrow (left)
import Data.Aeson (Value (String), withText)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as Base16
import Data.Map qualified as Map
import PlutusLedgerApi.V3 qualified as Plutus
import Test.QuickCheck (arbitrarySizedNatural, choose, oneof, scale, sized, vector)

-- * Extras

-- | Data-types that can be marshalled into a generic 'ScriptData' structure.
type ToScriptData a = Plutus.ToData a

-- | Data-types that can be unmarshalled from a generic 'ScriptData' structure.
type FromScriptData a = Plutus.FromData a

-- | Serialise some type into a generic script data.
toScriptData :: ToScriptData a => a -> HashableScriptData
toScriptData :: forall a. ToScriptData a => a -> HashableScriptData
toScriptData =
  -- NOTE: Safe to use here as the data was not available in serialized form.
  ScriptData -> HashableScriptData
unsafeHashableScriptData (ScriptData -> HashableScriptData)
-> (a -> ScriptData) -> a -> HashableScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> ScriptData
fromPlutusData (Data -> ScriptData) -> (a -> Data) -> a -> ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Data
forall a. ToData a => a -> Data
Plutus.toData

-- | Deserialise some generic script data into some type.
fromScriptData :: FromScriptData a => HashableScriptData -> Maybe a
fromScriptData :: forall a. FromScriptData a => HashableScriptData -> Maybe a
fromScriptData =
  Data -> Maybe a
forall a. FromData a => Data -> Maybe a
Plutus.fromData (Data -> Maybe a)
-> (HashableScriptData -> Data) -> HashableScriptData -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptData -> Data
toPlutusData (ScriptData -> Data)
-> (HashableScriptData -> ScriptData) -> HashableScriptData -> Data
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashableScriptData -> ScriptData
getScriptData

-- | Get the 'HashableScriptData' associated to the a 'TxOut'. Note that this
-- requires the 'CtxTx' context. To get script data in a 'CtxUTxO' context, see
-- 'lookupScriptData'.
txOutScriptData :: TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData :: forall era. TxOut CtxTx era -> Maybe HashableScriptData
txOutScriptData (TxOut AddressInEra era
_ TxOutValue era
_ TxOutDatum CtxTx era
d ReferenceScript era
_) =
  case TxOutDatum CtxTx era
d of
    TxOutDatumInTx AlonzoEraOnwards era
_ HashableScriptData
sd -> HashableScriptData -> Maybe HashableScriptData
forall a. a -> Maybe a
Just HashableScriptData
sd
    TxOutDatumInline BabbageEraOnwards era
_ HashableScriptData
sd -> HashableScriptData -> Maybe HashableScriptData
forall a. a -> Maybe a
Just HashableScriptData
sd
    TxOutDatum CtxTx era
_ -> Maybe HashableScriptData
forall a. Maybe a
Nothing

-- | Lookup included datum of given 'TxOut'.
lookupScriptData ::
  forall era.
  ( UsesStandardCrypto era
  , Ledger.Era (ShelleyLedgerEra era)
  ) =>
  Tx era ->
  TxOut CtxUTxO era ->
  Maybe HashableScriptData
lookupScriptData :: forall era.
(UsesStandardCrypto era, Era (ShelleyLedgerEra era)) =>
Tx era -> TxOut CtxUTxO era -> Maybe HashableScriptData
lookupScriptData (Tx (ShelleyTxBody ShelleyBasedEra era
_ TxBody (ShelleyLedgerEra era)
_ [Script (ShelleyLedgerEra era)]
_ TxBodyScriptData era
scriptsData Maybe (TxAuxData (ShelleyLedgerEra era))
_ TxScriptValidity era
_) [KeyWitness era]
_) (TxOut AddressInEra era
_ TxOutValue era
_ TxOutDatum CtxUTxO era
datum ReferenceScript era
_) =
  case TxOutDatum CtxUTxO era
datum of
    TxOutDatum CtxUTxO era
TxOutDatumNone ->
      Maybe HashableScriptData
forall a. Maybe a
Nothing
    (TxOutDatumHash AlonzoEraOnwards era
_ (ScriptDataHash DataHash StandardCrypto
h)) ->
      Data (ShelleyLedgerEra era) -> HashableScriptData
forall era. Data era -> HashableScriptData
fromLedgerData (Data (ShelleyLedgerEra era) -> HashableScriptData)
-> Maybe (Data (ShelleyLedgerEra era)) -> Maybe HashableScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DataHash StandardCrypto
-> Map (DataHash StandardCrypto) (Data (ShelleyLedgerEra era))
-> Maybe (Data (ShelleyLedgerEra era))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup DataHash StandardCrypto
h Map (DataHash StandardCrypto) (Data (ShelleyLedgerEra era))
datums
    (TxOutDatumInline BabbageEraOnwards era
_ HashableScriptData
dat) ->
      HashableScriptData -> Maybe HashableScriptData
forall a. a -> Maybe a
Just HashableScriptData
dat
 where
  datums :: Map (Ledger.DataHash StandardCrypto) (Ledger.Data (ShelleyLedgerEra era))
  datums :: Map (DataHash StandardCrypto) (Data (ShelleyLedgerEra era))
datums =
    case (TxBodyScriptData era
scriptsData :: TxBodyScriptData era) of
      TxBodyScriptData era
TxBodyNoScriptData -> Map (DataHash StandardCrypto) (Data (ShelleyLedgerEra era))
forall a. Monoid a => a
mempty
      TxBodyScriptData AlonzoEraOnwards era
_ (Ledger.TxDats Map
  (DataHash (EraCrypto (ShelleyLedgerEra era)))
  (Data (ShelleyLedgerEra era))
m) Redeemers (ShelleyLedgerEra era)
_ -> Map
  (DataHash (EraCrypto (ShelleyLedgerEra era)))
  (Data (ShelleyLedgerEra era))
Map (DataHash StandardCrypto) (Data (ShelleyLedgerEra era))
m

-- * Type Conversions

-- | Convert a cardano-ledger script 'Data' into a cardano-api 'ScriptDatum'.
fromLedgerData :: Ledger.Data era -> HashableScriptData
fromLedgerData :: forall era. Data era -> HashableScriptData
fromLedgerData =
  Data era -> HashableScriptData
forall era. Data era -> HashableScriptData
fromAlonzoData

-- | Convert a cardano-api script data into a cardano-ledger script 'Data'.
-- XXX: This is a partial function. Ideally it would fall back to the
-- 'Plutus.Data' portion in 'HashableScriptData'.
toLedgerData :: Ledger.Era era => HashableScriptData -> Ledger.Data era
toLedgerData :: forall era. Era era => HashableScriptData -> Data era
toLedgerData =
  HashableScriptData -> Data era
forall era. Era era => HashableScriptData -> Data era
toAlonzoData

-- * Orphans

instance ToJSON ScriptData where
  toJSON :: ScriptData -> Value
toJSON =
    Text -> Value
String
      (Text -> Value) -> (ScriptData -> Text) -> ScriptData -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8
      (ByteString -> Text)
-> (ScriptData -> ByteString) -> ScriptData -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode
      (ByteString -> ByteString)
-> (ScriptData -> ByteString) -> ScriptData -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict
      (ByteString -> ByteString)
-> (ScriptData -> ByteString) -> ScriptData -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> ByteString
forall a. Serialise a => a -> ByteString
serialise
      (Data -> ByteString)
-> (ScriptData -> Data) -> ScriptData -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptData -> Data
toPlutusData

instance FromJSON ScriptData where
  parseJSON :: Value -> Parser ScriptData
parseJSON Value
v = do
    Text
text :: Text <- Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    (String -> Parser ScriptData)
-> (Data -> Parser ScriptData)
-> Either String Data
-> Parser ScriptData
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser ScriptData
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ScriptData -> Parser ScriptData
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptData -> Parser ScriptData)
-> (Data -> ScriptData) -> Data -> Parser ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data -> ScriptData
fromPlutusData) (Either String Data -> Parser ScriptData)
-> Either String Data -> Parser ScriptData
forall a b. (a -> b) -> a -> b
$ do
      ByteString
bytes <- ByteString -> Either String ByteString
Base16.decode (Text -> ByteString
encodeUtf8 Text
text)
      (DeserialiseFailure -> String)
-> Either DeserialiseFailure Data -> Either String Data
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left DeserialiseFailure -> String
forall a. Show a => a -> String
show (Either DeserialiseFailure Data -> Either String Data)
-> Either DeserialiseFailure Data -> Either String Data
forall a b. (a -> b) -> a -> b
$ ByteString -> Either DeserialiseFailure Data
forall a. Serialise a => ByteString -> Either DeserialiseFailure a
deserialiseOrFail (ByteString -> Either DeserialiseFailure Data)
-> ByteString -> Either DeserialiseFailure Data
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict ByteString
bytes

instance Arbitrary ScriptData where
  arbitrary :: Gen ScriptData
arbitrary =
    (Int -> Int) -> Gen ScriptData -> Gen ScriptData
forall a. (Int -> Int) -> Gen a -> Gen a
scale (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) (Gen ScriptData -> Gen ScriptData)
-> Gen ScriptData -> Gen ScriptData
forall a b. (a -> b) -> a -> b
$
      [Gen ScriptData] -> Gen ScriptData
forall a. HasCallStack => [Gen a] -> Gen a
oneof
        [ Integer -> [ScriptData] -> ScriptData
ScriptDataConstructor (Integer -> [ScriptData] -> ScriptData)
-> Gen Integer -> Gen ([ScriptData] -> ScriptData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. Integral a => Gen a
arbitrarySizedNatural Gen ([ScriptData] -> ScriptData)
-> Gen [ScriptData] -> Gen ScriptData
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen [ScriptData]
forall a. Arbitrary a => Gen a
arbitrary
        , Integer -> ScriptData
ScriptDataNumber (Integer -> ScriptData) -> Gen Integer -> Gen ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Integer
forall a. Arbitrary a => Gen a
arbitrary
        , ByteString -> ScriptData
ScriptDataBytes (ByteString -> ScriptData) -> Gen ByteString -> Gen ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ByteString
arbitraryBS
        , [ScriptData] -> ScriptData
ScriptDataList ([ScriptData] -> ScriptData) -> Gen [ScriptData] -> Gen ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [ScriptData]
forall a. Arbitrary a => Gen a
arbitrary
        , [(ScriptData, ScriptData)] -> ScriptData
ScriptDataMap ([(ScriptData, ScriptData)] -> ScriptData)
-> Gen [(ScriptData, ScriptData)] -> Gen ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [(ScriptData, ScriptData)]
forall a. Arbitrary a => Gen a
arbitrary
        ]
   where
    arbitraryBS :: Gen ByteString
arbitraryBS = (Int -> Gen ByteString) -> Gen ByteString
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen ByteString) -> Gen ByteString)
-> (Int -> Gen ByteString) -> Gen ByteString
forall a b. (a -> b) -> a -> b
$ \Int
n ->
      [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> Gen [Word8] -> Gen ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
64) Gen Int -> (Int -> Gen [Word8]) -> Gen [Word8]
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Gen [Word8]
forall a. Arbitrary a => Int -> Gen [a]
vector)

instance ToJSON HashableScriptData where
  toJSON :: HashableScriptData -> Value
toJSON = Text -> Value
String (Text -> Value)
-> (HashableScriptData -> Text) -> HashableScriptData -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (HashableScriptData -> ByteString) -> HashableScriptData -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> ByteString)
-> (HashableScriptData -> ByteString)
-> HashableScriptData
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashableScriptData -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR

instance FromJSON HashableScriptData where
  parseJSON :: Value -> Parser HashableScriptData
parseJSON =
    String
-> (Text -> Parser HashableScriptData)
-> Value
-> Parser HashableScriptData
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"HashableScriptData" ((Text -> Parser HashableScriptData)
 -> Value -> Parser HashableScriptData)
-> (Text -> Parser HashableScriptData)
-> Value
-> Parser HashableScriptData
forall a b. (a -> b) -> a -> b
$ \Text
text -> do
      ByteString
bytes <- (String -> Parser ByteString)
-> (ByteString -> Parser ByteString)
-> Either String ByteString
-> Parser ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser ByteString
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString)
-> (String -> String) -> String -> Parser ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) ByteString -> Parser ByteString
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ByteString -> Parser ByteString)
-> Either String ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String ByteString
Base16.decode (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
text
      (DecoderError -> Parser HashableScriptData)
-> (HashableScriptData -> Parser HashableScriptData)
-> Either DecoderError HashableScriptData
-> Parser HashableScriptData
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Parser HashableScriptData
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser HashableScriptData)
-> (DecoderError -> String)
-> DecoderError
-> Parser HashableScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecoderError -> String
forall a. Show a => a -> String
show) HashableScriptData -> Parser HashableScriptData
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DecoderError HashableScriptData
 -> Parser HashableScriptData)
-> Either DecoderError HashableScriptData
-> Parser HashableScriptData
forall a b. (a -> b) -> a -> b
$ AsType HashableScriptData
-> ByteString -> Either DecoderError HashableScriptData
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR (Proxy HashableScriptData -> AsType HashableScriptData
forall t. HasTypeProxy t => Proxy t -> AsType t
proxyToAsType Proxy HashableScriptData
forall {k} (t :: k). Proxy t
Proxy) ByteString
bytes

instance Arbitrary HashableScriptData where
  arbitrary :: Gen HashableScriptData
arbitrary =
    -- NOTE: Safe to use here as the data was not available in serialized form.
    ScriptData -> HashableScriptData
unsafeHashableScriptData (ScriptData -> HashableScriptData)
-> Gen ScriptData -> Gen HashableScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen ScriptData
forall a. Arbitrary a => Gen a
arbitrary