{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Rpc.Server.Internal.UtxoRpc.Type.PlutusData
  ( scriptDataToUtxoRpcPlutusData
  , utxoRpcPlutusDataToScriptData
  )
where

import Cardano.Api.Era
import Cardano.Api.Plutus
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as U5c
import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
import Cardano.Rpc.Server.Internal.Orphans ()
import Cardano.Rpc.Server.Internal.UtxoRpc.Type.BigInt

import RIO

import Data.ProtoLens (defMessage)
import Network.GRPC.Spec

scriptDataToUtxoRpcPlutusData :: ScriptData -> Proto UtxoRpc.PlutusData
scriptDataToUtxoRpcPlutusData :: ScriptData -> Proto PlutusData
scriptDataToUtxoRpcPlutusData = \case
  ScriptDataBytes ByteString
bs ->
    Proto PlutusData
forall msg. Message msg => msg
defMessage Proto PlutusData
-> (Proto PlutusData -> Proto PlutusData) -> Proto PlutusData
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto PlutusData) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "boundedBytes" a) =>
LensLike' f s a
U5c.boundedBytes LensLike' Identity (Proto PlutusData) ByteString
-> ByteString -> Proto PlutusData -> Proto PlutusData
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ByteString
bs
  ScriptDataNumber Integer
int -> Proto PlutusData
forall msg. Message msg => msg
defMessage Proto PlutusData
-> (Proto PlutusData -> Proto PlutusData) -> Proto PlutusData
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto PlutusData) (Proto BigInt)
forall (f :: * -> *) s a.
(Functor f, HasField s "bigInt" a) =>
LensLike' f s a
U5c.bigInt LensLike' Identity (Proto PlutusData) (Proto BigInt)
-> Proto BigInt -> Proto PlutusData -> Proto PlutusData
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Proto BigInt
forall t s. Inject t s => t -> s
inject Integer
int
  ScriptDataList [ScriptData]
sds ->
    Proto PlutusData
forall msg. Message msg => msg
defMessage Proto PlutusData
-> (Proto PlutusData -> Proto PlutusData) -> Proto PlutusData
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto PlutusData) (Proto PlutusDataArray)
forall (f :: * -> *) s a.
(Functor f, HasField s "array" a) =>
LensLike' f s a
U5c.array LensLike' Identity (Proto PlutusData) (Proto PlutusDataArray)
-> (([Proto PlutusData] -> Identity [Proto PlutusData])
    -> Proto PlutusDataArray -> Identity (Proto PlutusDataArray))
-> ([Proto PlutusData] -> Identity [Proto PlutusData])
-> Proto PlutusData
-> Identity (Proto PlutusData)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Proto PlutusData] -> Identity [Proto PlutusData])
-> Proto PlutusDataArray -> Identity (Proto PlutusDataArray)
forall (f :: * -> *) s a.
(Functor f, HasField s "items" a) =>
LensLike' f s a
U5c.items (([Proto PlutusData] -> Identity [Proto PlutusData])
 -> Proto PlutusData -> Identity (Proto PlutusData))
-> [Proto PlutusData] -> Proto PlutusData -> Proto PlutusData
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (ScriptData -> Proto PlutusData)
-> [ScriptData] -> [Proto PlutusData]
forall a b. (a -> b) -> [a] -> [b]
map ScriptData -> Proto PlutusData
scriptDataToUtxoRpcPlutusData [ScriptData]
sds
  ScriptDataMap [(ScriptData, ScriptData)]
elements -> do
    let pairs :: [Proto PlutusDataPair]
pairs =
          [(ScriptData, ScriptData)]
elements [(ScriptData, ScriptData)]
-> ((ScriptData, ScriptData) -> Proto PlutusDataPair)
-> [Proto PlutusDataPair]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(ScriptData
k, ScriptData
v) ->
            Proto PlutusDataPair
forall msg. Message msg => msg
defMessage
              Proto PlutusDataPair
-> (Proto PlutusDataPair -> Proto PlutusDataPair)
-> Proto PlutusDataPair
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto PlutusDataPair) (Proto PlutusData)
forall (f :: * -> *) s a.
(Functor f, HasField s "key" a) =>
LensLike' f s a
U5c.key LensLike' Identity (Proto PlutusDataPair) (Proto PlutusData)
-> Proto PlutusData -> Proto PlutusDataPair -> Proto PlutusDataPair
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ScriptData -> Proto PlutusData
scriptDataToUtxoRpcPlutusData ScriptData
k
              Proto PlutusDataPair
-> (Proto PlutusDataPair -> Proto PlutusDataPair)
-> Proto PlutusDataPair
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto PlutusDataPair) (Proto PlutusData)
forall (f :: * -> *) s a.
(Functor f, HasField s "value" a) =>
LensLike' f s a
U5c.value LensLike' Identity (Proto PlutusDataPair) (Proto PlutusData)
-> Proto PlutusData -> Proto PlutusDataPair -> Proto PlutusDataPair
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ScriptData -> Proto PlutusData
scriptDataToUtxoRpcPlutusData ScriptData
v
    Proto PlutusData
forall msg. Message msg => msg
defMessage Proto PlutusData
-> (Proto PlutusData -> Proto PlutusData) -> Proto PlutusData
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto PlutusData) (Proto PlutusDataMap)
forall (f :: * -> *) s a.
(Functor f, HasField s "map" a) =>
LensLike' f s a
U5c.map LensLike' Identity (Proto PlutusData) (Proto PlutusDataMap)
-> (([Proto PlutusDataPair] -> Identity [Proto PlutusDataPair])
    -> Proto PlutusDataMap -> Identity (Proto PlutusDataMap))
-> ([Proto PlutusDataPair] -> Identity [Proto PlutusDataPair])
-> Proto PlutusData
-> Identity (Proto PlutusData)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Proto PlutusDataPair] -> Identity [Proto PlutusDataPair])
-> Proto PlutusDataMap -> Identity (Proto PlutusDataMap)
forall (f :: * -> *) s a.
(Functor f, HasField s "pairs" a) =>
LensLike' f s a
U5c.pairs (([Proto PlutusDataPair] -> Identity [Proto PlutusDataPair])
 -> Proto PlutusData -> Identity (Proto PlutusData))
-> [Proto PlutusDataPair] -> Proto PlutusData -> Proto PlutusData
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Proto PlutusDataPair]
pairs
  ScriptDataConstructor Integer
tag [ScriptData]
args -> do
    -- Details of plutus tag serialisation:
    -- https://github.com/IntersectMBO/plutus/blob/fc78c36b545ee287ae8796a0c1a7d04cf31f4cee/plutus-core/plutus-core/src/PlutusCore/Data.hs#L72
    let constr :: Proto Constr
constr =
          Proto Constr
forall msg. Message msg => msg
defMessage
            Proto Constr -> (Proto Constr -> Proto Constr) -> Proto Constr
forall a b. a -> (a -> b) -> b
& ( if Integer
tag Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound @Word32)
                  then LensLike' Identity (Proto Constr) Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "tag" a) =>
LensLike' f s a
U5c.tag LensLike' Identity (Proto Constr) Word32
-> Word32 -> Proto Constr -> Proto Constr
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
tag
                  else (LensLike' Identity (Proto Constr) Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "tag" a) =>
LensLike' f s a
U5c.tag LensLike' Identity (Proto Constr) Word32
-> Word32 -> Proto Constr -> Proto Constr
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32
102) (Proto Constr -> Proto Constr)
-> (Proto Constr -> Proto Constr) -> Proto Constr -> Proto Constr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LensLike' Identity (Proto Constr) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "anyConstructor" a) =>
LensLike' f s a
U5c.anyConstructor LensLike' Identity (Proto Constr) Word64
-> Word64 -> Proto Constr -> Proto Constr
forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a b. (Integral a, Num b) => a -> b
fromIntegral @_ @Word64 Integer
tag)
              )
            Proto Constr -> (Proto Constr -> Proto Constr) -> Proto Constr
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto Constr) [Proto PlutusData]
forall (f :: * -> *) s a.
(Functor f, HasField s "fields" a) =>
LensLike' f s a
U5c.fields LensLike' Identity (Proto Constr) [Proto PlutusData]
-> [Proto PlutusData] -> Proto Constr -> Proto Constr
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (ScriptData -> Proto PlutusData)
-> [ScriptData] -> [Proto PlutusData]
forall a b. (a -> b) -> [a] -> [b]
map ScriptData -> Proto PlutusData
scriptDataToUtxoRpcPlutusData [ScriptData]
args
    Proto PlutusData
forall msg. Message msg => msg
defMessage Proto PlutusData
-> (Proto PlutusData -> Proto PlutusData) -> Proto PlutusData
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto PlutusData) (Proto Constr)
forall (f :: * -> *) s a.
(Functor f, HasField s "constr" a) =>
LensLike' f s a
U5c.constr LensLike' Identity (Proto PlutusData) (Proto Constr)
-> Proto Constr -> Proto PlutusData -> Proto PlutusData
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Proto Constr
constr

utxoRpcPlutusDataToScriptData
  :: HasCallStack
  => MonadThrow m
  => Proto UtxoRpc.PlutusData
  -> m ScriptData
utxoRpcPlutusDataToScriptData :: forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
Proto PlutusData -> m ScriptData
utxoRpcPlutusDataToScriptData Proto PlutusData
pd
  | Just ByteString
bs <- Proto PlutusData
pd Proto PlutusData
-> Getting (Maybe ByteString) (Proto PlutusData) (Maybe ByteString)
-> Maybe ByteString
forall s a. s -> Getting a s a -> a
^. Getting (Maybe ByteString) (Proto PlutusData) (Maybe ByteString)
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'boundedBytes" a) =>
LensLike' f s a
U5c.maybe'boundedBytes =
      ScriptData -> m ScriptData
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptData -> m ScriptData) -> ScriptData -> m ScriptData
forall a b. (a -> b) -> a -> b
$ ByteString -> ScriptData
ScriptDataBytes ByteString
bs
  | Just Proto BigInt
bigInt <- Proto PlutusData
pd Proto PlutusData
-> Getting
     (Maybe (Proto BigInt)) (Proto PlutusData) (Maybe (Proto BigInt))
-> Maybe (Proto BigInt)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Proto BigInt)) (Proto PlutusData) (Maybe (Proto BigInt))
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'bigInt" a) =>
LensLike' f s a
U5c.maybe'bigInt =
      Integer -> ScriptData
ScriptDataNumber (Integer -> ScriptData) -> m Integer -> m ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proto BigInt -> m Integer
forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
Proto BigInt -> m Integer
utxoRpcBigIntToInteger Proto BigInt
bigInt
  | Just Proto PlutusDataArray
arr <- Proto PlutusData
pd Proto PlutusData
-> Getting
     (Maybe (Proto PlutusDataArray))
     (Proto PlutusData)
     (Maybe (Proto PlutusDataArray))
-> Maybe (Proto PlutusDataArray)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Proto PlutusDataArray))
  (Proto PlutusData)
  (Maybe (Proto PlutusDataArray))
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'array" a) =>
LensLike' f s a
U5c.maybe'array =
      [ScriptData] -> ScriptData
ScriptDataList ([ScriptData] -> ScriptData) -> m [ScriptData] -> m ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Proto PlutusData -> m ScriptData)
-> [Proto PlutusData] -> m [ScriptData]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Proto PlutusData -> m ScriptData
forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
Proto PlutusData -> m ScriptData
utxoRpcPlutusDataToScriptData (Proto PlutusDataArray
arr Proto PlutusDataArray
-> Getting
     [Proto PlutusData] (Proto PlutusDataArray) [Proto PlutusData]
-> [Proto PlutusData]
forall s a. s -> Getting a s a -> a
^. Getting
  [Proto PlutusData] (Proto PlutusDataArray) [Proto PlutusData]
forall (f :: * -> *) s a.
(Functor f, HasField s "items" a) =>
LensLike' f s a
U5c.items)
  | Just Proto PlutusDataMap
m <- Proto PlutusData
pd Proto PlutusData
-> Getting
     (Maybe (Proto PlutusDataMap))
     (Proto PlutusData)
     (Maybe (Proto PlutusDataMap))
-> Maybe (Proto PlutusDataMap)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Proto PlutusDataMap))
  (Proto PlutusData)
  (Maybe (Proto PlutusDataMap))
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'map" a) =>
LensLike' f s a
U5c.maybe'map = do
      let convertPair :: s -> m (ScriptData, ScriptData)
convertPair s
pair = do
            k <- Proto PlutusData -> m ScriptData
forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
Proto PlutusData -> m ScriptData
utxoRpcPlutusDataToScriptData (Proto PlutusData -> m ScriptData)
-> Proto PlutusData -> m ScriptData
forall a b. (a -> b) -> a -> b
$ s
pair s
-> Getting (Proto PlutusData) s (Proto PlutusData)
-> Proto PlutusData
forall s a. s -> Getting a s a -> a
^. Getting (Proto PlutusData) s (Proto PlutusData)
forall (f :: * -> *) s a.
(Functor f, HasField s "key" a) =>
LensLike' f s a
U5c.key
            v <- utxoRpcPlutusDataToScriptData $ pair ^. U5c.value
            pure (k, v)
      [(ScriptData, ScriptData)] -> ScriptData
ScriptDataMap ([(ScriptData, ScriptData)] -> ScriptData)
-> m [(ScriptData, ScriptData)] -> m ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Proto PlutusDataPair -> m (ScriptData, ScriptData))
-> [Proto PlutusDataPair] -> m [(ScriptData, ScriptData)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Proto PlutusDataPair -> m (ScriptData, ScriptData)
forall {m :: * -> *} {s}.
(MonadThrow m, HasField s "value" (Proto PlutusData),
 HasField s "key" (Proto PlutusData)) =>
s -> m (ScriptData, ScriptData)
convertPair (Proto PlutusDataMap
m Proto PlutusDataMap
-> Getting
     [Proto PlutusDataPair] (Proto PlutusDataMap) [Proto PlutusDataPair]
-> [Proto PlutusDataPair]
forall s a. s -> Getting a s a -> a
^. Getting
  [Proto PlutusDataPair] (Proto PlutusDataMap) [Proto PlutusDataPair]
forall (f :: * -> *) s a.
(Functor f, HasField s "pairs" a) =>
LensLike' f s a
U5c.pairs)
  | Just Proto Constr
constr <- Proto PlutusData
pd Proto PlutusData
-> Getting
     (Maybe (Proto Constr)) (Proto PlutusData) (Maybe (Proto Constr))
-> Maybe (Proto Constr)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Proto Constr)) (Proto PlutusData) (Maybe (Proto Constr))
forall (f :: * -> *) s a.
(Functor f, HasField s "maybe'constr" a) =>
LensLike' f s a
U5c.maybe'constr = do
      let tag :: Word32
tag = Proto Constr
constr Proto Constr -> Getting Word32 (Proto Constr) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (Proto Constr) Word32
forall (f :: * -> *) s a.
(Functor f, HasField s "tag" a) =>
LensLike' f s a
U5c.tag
          anyC :: Word64
anyC = Proto Constr
constr Proto Constr -> Getting Word64 (Proto Constr) Word64 -> Word64
forall s a. s -> Getting a s a -> a
^. Getting Word64 (Proto Constr) Word64
forall (f :: * -> *) s a.
(Functor f, HasField s "anyConstructor" a) =>
LensLike' f s a
U5c.anyConstructor
          -- Inverse of scriptDataToUtxoRpcPlutusData: tag 102 signals that the
          -- real constructor index lives in anyConstructor (for values > maxBound @Word32).
          -- See: https://github.com/IntersectMBO/plutus/blob/fc78c36b545ee287ae8796a0c1a7d04cf31f4cee/plutus-core/plutus-core/src/PlutusCore/Data.hs#L72
          resolvedTag :: Integer
resolvedTag =
            if Word32
tag Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
102 Bool -> Bool -> Bool
&& Word64
anyC Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0
              then Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
anyC
              else Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
tag
      fields <- (Proto PlutusData -> m ScriptData)
-> [Proto PlutusData] -> m [ScriptData]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Proto PlutusData -> m ScriptData
forall (m :: * -> *).
(HasCallStack, MonadThrow m) =>
Proto PlutusData -> m ScriptData
utxoRpcPlutusDataToScriptData ([Proto PlutusData] -> m [ScriptData])
-> [Proto PlutusData] -> m [ScriptData]
forall a b. (a -> b) -> a -> b
$ Proto Constr
constr Proto Constr
-> Getting [Proto PlutusData] (Proto Constr) [Proto PlutusData]
-> [Proto PlutusData]
forall s a. s -> Getting a s a -> a
^. Getting [Proto PlutusData] (Proto Constr) [Proto PlutusData]
forall (f :: * -> *) s a.
(Functor f, HasField s "fields" a) =>
LensLike' f s a
U5c.fields
      pure $ ScriptDataConstructor resolvedTag fields
  | Bool
otherwise =
      StringException -> m ScriptData
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (StringException -> m ScriptData)
-> ([Char] -> StringException) -> [Char] -> m ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => [Char] -> StringException
[Char] -> StringException
stringException ([Char] -> m ScriptData) -> [Char] -> m ScriptData
forall a b. (a -> b) -> a -> b
$ [Char]
"utxoRpcPlutusDataToScriptData: no PlutusData variant set"