{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Api.ScriptData (
    -- * Script data
    ScriptData(..),

    -- * Script data hashes
    hashScriptData,

    -- * Validating metadata
    validateScriptData,
    ScriptDataRangeError (..),

    -- * Conversion to\/from JSON
    ScriptDataJsonSchema (..),
    scriptDataFromJson,
    scriptDataToJson,
    ScriptDataJsonError (..),
    ScriptDataJsonSchemaError (..),
    scriptDataFromJsonDetailedSchema,
    scriptDataToJsonDetailedSchema,

    -- * Internal conversion functions
    toPlutusData,
    fromPlutusData,
    toAlonzoData,
    fromAlonzoData,

    -- * Data family instances
    AsType(..),
    Hash(..),
  ) where

import           Prelude

import           Data.Bifunctor (first)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Char as Char
import qualified Data.List as List
import           Data.Maybe (fromMaybe)
import qualified Data.Scientific as Scientific
import           Data.String (IsString)
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Vector as Vector
import           Data.Word

import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as Aeson
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.Aeson.Text as Aeson.Text
import qualified Data.Attoparsec.ByteString.Char8 as Atto

import           Control.Applicative (Alternative (..))

import qualified Cardano.Crypto.Hash.Class as Crypto
import qualified Cardano.Ledger.Alonzo.Data as Alonzo
import qualified Cardano.Ledger.SafeHash as Ledger
import           Ouroboros.Consensus.Shelley.Eras (StandardAlonzo, StandardCrypto)
import qualified Plutus.V1.Ledger.Api as Plutus

import           Cardano.Api.Eras
import           Cardano.Api.Error
import           Cardano.Api.HasTypeProxy
import           Cardano.Api.Hash
import           Cardano.Api.KeysShelley
import           Cardano.Api.SerialiseCBOR
import           Cardano.Api.SerialiseJSON
import           Cardano.Api.SerialiseRaw
import qualified Cardano.Binary as CBOR

import           Cardano.Api.SerialiseUsing
import           Cardano.Api.TxMetadata (pBytes, pSigned, parseAll)
import           Codec.Serialise.Class (Serialise (..))

-- ----------------------------------------------------------------------------
-- Script data
--

data ScriptData = ScriptDataConstructor
                                        Integer                     -- ^ Tag for the constructor
                                        [ScriptData]                -- ^ Constructor arguments
                | ScriptDataMap         [(ScriptData, ScriptData)]  -- ^ Key value pairs
                | ScriptDataList        [ScriptData]                -- ^ Elements
                | ScriptDataNumber      Integer
                | ScriptDataBytes       BS.ByteString
  deriving (ScriptData -> ScriptData -> Bool
(ScriptData -> ScriptData -> Bool)
-> (ScriptData -> ScriptData -> Bool) -> Eq ScriptData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptData -> ScriptData -> Bool
$c/= :: ScriptData -> ScriptData -> Bool
== :: ScriptData -> ScriptData -> Bool
$c== :: ScriptData -> ScriptData -> Bool
Eq, Eq ScriptData
Eq ScriptData
-> (ScriptData -> ScriptData -> Ordering)
-> (ScriptData -> ScriptData -> Bool)
-> (ScriptData -> ScriptData -> Bool)
-> (ScriptData -> ScriptData -> Bool)
-> (ScriptData -> ScriptData -> Bool)
-> (ScriptData -> ScriptData -> ScriptData)
-> (ScriptData -> ScriptData -> ScriptData)
-> Ord ScriptData
ScriptData -> ScriptData -> Bool
ScriptData -> ScriptData -> Ordering
ScriptData -> ScriptData -> ScriptData
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ScriptData -> ScriptData -> ScriptData
$cmin :: ScriptData -> ScriptData -> ScriptData
max :: ScriptData -> ScriptData -> ScriptData
$cmax :: ScriptData -> ScriptData -> ScriptData
>= :: ScriptData -> ScriptData -> Bool
$c>= :: ScriptData -> ScriptData -> Bool
> :: ScriptData -> ScriptData -> Bool
$c> :: ScriptData -> ScriptData -> Bool
<= :: ScriptData -> ScriptData -> Bool
$c<= :: ScriptData -> ScriptData -> Bool
< :: ScriptData -> ScriptData -> Bool
$c< :: ScriptData -> ScriptData -> Bool
compare :: ScriptData -> ScriptData -> Ordering
$ccompare :: ScriptData -> ScriptData -> Ordering
$cp1Ord :: Eq ScriptData
Ord, Int -> ScriptData -> ShowS
[ScriptData] -> ShowS
ScriptData -> String
(Int -> ScriptData -> ShowS)
-> (ScriptData -> String)
-> ([ScriptData] -> ShowS)
-> Show ScriptData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptData] -> ShowS
$cshowList :: [ScriptData] -> ShowS
show :: ScriptData -> String
$cshow :: ScriptData -> String
showsPrec :: Int -> ScriptData -> ShowS
$cshowsPrec :: Int -> ScriptData -> ShowS
Show)
  -- Note the order of constructors is the same as the Plutus definitions
  -- so that the Ord instance is consistent with the Plutus one.
  -- This is checked by prop_ord_distributive_ScriptData

instance HasTypeProxy ScriptData where
    data AsType ScriptData = AsScriptData
    proxyToAsType :: Proxy ScriptData -> AsType ScriptData
proxyToAsType Proxy ScriptData
_ = AsType ScriptData
AsScriptData

-- ----------------------------------------------------------------------------
-- Script data hash
--

newtype instance Hash ScriptData =
    ScriptDataHash (Alonzo.DataHash StandardCrypto)
  deriving stock (Hash ScriptData -> Hash ScriptData -> Bool
(Hash ScriptData -> Hash ScriptData -> Bool)
-> (Hash ScriptData -> Hash ScriptData -> Bool)
-> Eq (Hash ScriptData)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Hash ScriptData -> Hash ScriptData -> Bool
$c/= :: Hash ScriptData -> Hash ScriptData -> Bool
== :: Hash ScriptData -> Hash ScriptData -> Bool
$c== :: Hash ScriptData -> Hash ScriptData -> Bool
Eq, Eq (Hash ScriptData)
Eq (Hash ScriptData)
-> (Hash ScriptData -> Hash ScriptData -> Ordering)
-> (Hash ScriptData -> Hash ScriptData -> Bool)
-> (Hash ScriptData -> Hash ScriptData -> Bool)
-> (Hash ScriptData -> Hash ScriptData -> Bool)
-> (Hash ScriptData -> Hash ScriptData -> Bool)
-> (Hash ScriptData -> Hash ScriptData -> Hash ScriptData)
-> (Hash ScriptData -> Hash ScriptData -> Hash ScriptData)
-> Ord (Hash ScriptData)
Hash ScriptData -> Hash ScriptData -> Bool
Hash ScriptData -> Hash ScriptData -> Ordering
Hash ScriptData -> Hash ScriptData -> Hash ScriptData
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Hash ScriptData -> Hash ScriptData -> Hash ScriptData
$cmin :: Hash ScriptData -> Hash ScriptData -> Hash ScriptData
max :: Hash ScriptData -> Hash ScriptData -> Hash ScriptData
$cmax :: Hash ScriptData -> Hash ScriptData -> Hash ScriptData
>= :: Hash ScriptData -> Hash ScriptData -> Bool
$c>= :: Hash ScriptData -> Hash ScriptData -> Bool
> :: Hash ScriptData -> Hash ScriptData -> Bool
$c> :: Hash ScriptData -> Hash ScriptData -> Bool
<= :: Hash ScriptData -> Hash ScriptData -> Bool
$c<= :: Hash ScriptData -> Hash ScriptData -> Bool
< :: Hash ScriptData -> Hash ScriptData -> Bool
$c< :: Hash ScriptData -> Hash ScriptData -> Bool
compare :: Hash ScriptData -> Hash ScriptData -> Ordering
$ccompare :: Hash ScriptData -> Hash ScriptData -> Ordering
$cp1Ord :: Eq (Hash ScriptData)
Ord)
  deriving (Int -> Hash ScriptData -> ShowS
[Hash ScriptData] -> ShowS
Hash ScriptData -> String
(Int -> Hash ScriptData -> ShowS)
-> (Hash ScriptData -> String)
-> ([Hash ScriptData] -> ShowS)
-> Show (Hash ScriptData)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Hash ScriptData] -> ShowS
$cshowList :: [Hash ScriptData] -> ShowS
show :: Hash ScriptData -> String
$cshow :: Hash ScriptData -> String
showsPrec :: Int -> Hash ScriptData -> ShowS
$cshowsPrec :: Int -> Hash ScriptData -> ShowS
Show, String -> Hash ScriptData
(String -> Hash ScriptData) -> IsString (Hash ScriptData)
forall a. (String -> a) -> IsString a
fromString :: String -> Hash ScriptData
$cfromString :: String -> Hash ScriptData
IsString)         via UsingRawBytesHex (Hash ScriptData)
  deriving ([Hash ScriptData] -> Encoding
[Hash ScriptData] -> Value
Hash ScriptData -> Encoding
Hash ScriptData -> Value
(Hash ScriptData -> Value)
-> (Hash ScriptData -> Encoding)
-> ([Hash ScriptData] -> Value)
-> ([Hash ScriptData] -> Encoding)
-> ToJSON (Hash ScriptData)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Hash ScriptData] -> Encoding
$ctoEncodingList :: [Hash ScriptData] -> Encoding
toJSONList :: [Hash ScriptData] -> Value
$ctoJSONList :: [Hash ScriptData] -> Value
toEncoding :: Hash ScriptData -> Encoding
$ctoEncoding :: Hash ScriptData -> Encoding
toJSON :: Hash ScriptData -> Value
$ctoJSON :: Hash ScriptData -> Value
ToJSON, Value -> Parser [Hash ScriptData]
Value -> Parser (Hash ScriptData)
(Value -> Parser (Hash ScriptData))
-> (Value -> Parser [Hash ScriptData])
-> FromJSON (Hash ScriptData)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Hash ScriptData]
$cparseJSONList :: Value -> Parser [Hash ScriptData]
parseJSON :: Value -> Parser (Hash ScriptData)
$cparseJSON :: Value -> Parser (Hash ScriptData)
FromJSON)       via UsingRawBytesHex (Hash ScriptData)
  deriving (ToJSONKeyFunction [Hash ScriptData]
ToJSONKeyFunction (Hash ScriptData)
ToJSONKeyFunction (Hash ScriptData)
-> ToJSONKeyFunction [Hash ScriptData]
-> ToJSONKey (Hash ScriptData)
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
toJSONKeyList :: ToJSONKeyFunction [Hash ScriptData]
$ctoJSONKeyList :: ToJSONKeyFunction [Hash ScriptData]
toJSONKey :: ToJSONKeyFunction (Hash ScriptData)
$ctoJSONKey :: ToJSONKeyFunction (Hash ScriptData)
ToJSONKey, FromJSONKeyFunction [Hash ScriptData]
FromJSONKeyFunction (Hash ScriptData)
FromJSONKeyFunction (Hash ScriptData)
-> FromJSONKeyFunction [Hash ScriptData]
-> FromJSONKey (Hash ScriptData)
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
fromJSONKeyList :: FromJSONKeyFunction [Hash ScriptData]
$cfromJSONKeyList :: FromJSONKeyFunction [Hash ScriptData]
fromJSONKey :: FromJSONKeyFunction (Hash ScriptData)
$cfromJSONKey :: FromJSONKeyFunction (Hash ScriptData)
FromJSONKey) via UsingRawBytesHex (Hash ScriptData)

instance SerialiseAsRawBytes (Hash ScriptData) where
    serialiseToRawBytes :: Hash ScriptData -> ByteString
serialiseToRawBytes (ScriptDataHash dh) =
      Hash Blake2b_256 EraIndependentData -> ByteString
forall h a. Hash h a -> ByteString
Crypto.hashToBytes (SafeHash StandardCrypto EraIndependentData
-> Hash (HASH StandardCrypto) EraIndependentData
forall crypto i. SafeHash crypto i -> Hash (HASH crypto) i
Ledger.extractHash SafeHash StandardCrypto EraIndependentData
dh)

    deserialiseFromRawBytes :: AsType (Hash ScriptData) -> ByteString -> Maybe (Hash ScriptData)
deserialiseFromRawBytes (AsHash AsScriptData) ByteString
bs =
      SafeHash StandardCrypto EraIndependentData -> Hash ScriptData
ScriptDataHash (SafeHash StandardCrypto EraIndependentData -> Hash ScriptData)
-> (Hash Blake2b_256 EraIndependentData
    -> SafeHash StandardCrypto EraIndependentData)
-> Hash Blake2b_256 EraIndependentData
-> Hash ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash Blake2b_256 EraIndependentData
-> SafeHash StandardCrypto EraIndependentData
forall crypto index.
Hash (HASH crypto) index -> SafeHash crypto index
Ledger.unsafeMakeSafeHash (Hash Blake2b_256 EraIndependentData -> Hash ScriptData)
-> Maybe (Hash Blake2b_256 EraIndependentData)
-> Maybe (Hash ScriptData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe (Hash Blake2b_256 EraIndependentData)
forall h a. HashAlgorithm h => ByteString -> Maybe (Hash h a)
Crypto.hashFromBytes ByteString
bs

instance SerialiseAsCBOR ScriptData where
    serialiseToCBOR :: ScriptData -> ByteString
serialiseToCBOR = ScriptData -> ByteString
forall a. ToCBOR a => a -> ByteString
CBOR.serialize'
    deserialiseFromCBOR :: AsType ScriptData -> ByteString -> Either DecoderError ScriptData
deserialiseFromCBOR AsType ScriptData
AsScriptData ByteString
bs = Text
-> (forall s. Decoder s ScriptData)
-> LByteString
-> Either DecoderError ScriptData
forall a.
Text
-> (forall s. Decoder s a) -> LByteString -> Either DecoderError a
CBOR.decodeFullDecoder Text
"ScriptData" forall s. Decoder s ScriptData
forall a s. FromCBOR a => Decoder s a
fromCBOR (ByteString -> LByteString
LBS.fromStrict ByteString
bs) :: Either CBOR.DecoderError ScriptData


instance ToCBOR ScriptData where
  toCBOR :: ScriptData -> Encoding
toCBOR = Serialise Data => Data -> Encoding
forall a. Serialise a => a -> Encoding
encode @Plutus.Data (Data -> Encoding)
-> (ScriptData -> Data) -> ScriptData -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptData -> Data
toPlutusData

instance FromCBOR ScriptData where
  fromCBOR :: Decoder s ScriptData
fromCBOR = Data -> ScriptData
fromPlutusData (Data -> ScriptData) -> Decoder s Data -> Decoder s ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Serialise Data => Decoder s Data
forall a s. Serialise a => Decoder s a
decode @Plutus.Data

hashScriptData :: ScriptData -> Hash ScriptData
hashScriptData :: ScriptData -> Hash ScriptData
hashScriptData = SafeHash StandardCrypto EraIndependentData -> Hash ScriptData
ScriptDataHash
               (SafeHash StandardCrypto EraIndependentData -> Hash ScriptData)
-> (ScriptData -> SafeHash StandardCrypto EraIndependentData)
-> ScriptData
-> Hash ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data StandardAlonzo -> SafeHash StandardCrypto EraIndependentData
forall era. Era era => Data era -> DataHash (Crypto era)
Alonzo.hashData
               (Data StandardAlonzo -> SafeHash StandardCrypto EraIndependentData)
-> (ScriptData -> Data StandardAlonzo)
-> ScriptData
-> SafeHash StandardCrypto EraIndependentData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScriptData -> Data StandardAlonzo
forall ledgerera. ScriptData -> Data ledgerera
toAlonzoData :: ScriptData -> Alonzo.Data StandardAlonzo)


-- ----------------------------------------------------------------------------
-- Conversion functions
--

toAlonzoData :: ScriptData -> Alonzo.Data ledgerera
toAlonzoData :: ScriptData -> Data ledgerera
toAlonzoData = Data -> Data ledgerera
forall era. Data -> Data era
Alonzo.Data (Data -> Data ledgerera)
-> (ScriptData -> Data) -> ScriptData -> Data ledgerera
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptData -> Data
toPlutusData

fromAlonzoData :: Alonzo.Data ledgerera -> ScriptData
fromAlonzoData :: Data ledgerera -> ScriptData
fromAlonzoData = Data -> ScriptData
fromPlutusData (Data -> ScriptData)
-> (Data ledgerera -> Data) -> Data ledgerera -> ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Data ledgerera -> Data
forall era. Data era -> Data
Alonzo.getPlutusData


toPlutusData :: ScriptData -> Plutus.Data
toPlutusData :: ScriptData -> Data
toPlutusData (ScriptDataConstructor Integer
int [ScriptData]
xs)
                                  = Integer -> [Data] -> Data
Plutus.Constr Integer
int
                                      [ ScriptData -> Data
toPlutusData ScriptData
x | ScriptData
x <- [ScriptData]
xs ]
toPlutusData (ScriptDataMap  [(ScriptData, ScriptData)]
kvs) = [(Data, Data)] -> Data
Plutus.Map
                                      [ (ScriptData -> Data
toPlutusData ScriptData
k, ScriptData -> Data
toPlutusData ScriptData
v)
                                      | (ScriptData
k,ScriptData
v) <- [(ScriptData, ScriptData)]
kvs ]
toPlutusData (ScriptDataList  [ScriptData]
xs) = [Data] -> Data
Plutus.List
                                      [ ScriptData -> Data
toPlutusData ScriptData
x | ScriptData
x <- [ScriptData]
xs ]
toPlutusData (ScriptDataNumber Integer
n) = Integer -> Data
Plutus.I Integer
n
toPlutusData (ScriptDataBytes ByteString
bs) = ByteString -> Data
Plutus.B ByteString
bs


fromPlutusData :: Plutus.Data -> ScriptData
fromPlutusData :: Data -> ScriptData
fromPlutusData (Plutus.Constr Integer
int [Data]
xs)
                                = Integer -> [ScriptData] -> ScriptData
ScriptDataConstructor Integer
int
                                    [ Data -> ScriptData
fromPlutusData Data
x | Data
x <- [Data]
xs ]
fromPlutusData (Plutus.Map [(Data, Data)]
kvs) = [(ScriptData, ScriptData)] -> ScriptData
ScriptDataMap
                                    [ (Data -> ScriptData
fromPlutusData Data
k, Data -> ScriptData
fromPlutusData Data
v)
                                    | (Data
k,Data
v) <- [(Data, Data)]
kvs ]
fromPlutusData (Plutus.List [Data]
xs) = [ScriptData] -> ScriptData
ScriptDataList
                                    [ Data -> ScriptData
fromPlutusData Data
x | Data
x <- [Data]
xs ]
fromPlutusData (Plutus.I     Integer
n) = Integer -> ScriptData
ScriptDataNumber Integer
n
fromPlutusData (Plutus.B    ByteString
bs) = ByteString -> ScriptData
ScriptDataBytes ByteString
bs


-- ----------------------------------------------------------------------------
-- Validate script data
--

-- | Validate script data. This is for use with existing constructed script
-- data values, e.g. constructed manually or decoded from CBOR directly.
--
validateScriptData :: ScriptData -> Either ScriptDataRangeError ()
validateScriptData :: ScriptData -> Either ScriptDataRangeError ()
validateScriptData ScriptData
d =
    case ScriptData -> [ScriptDataRangeError]
collect ScriptData
d of
      []    -> () -> Either ScriptDataRangeError ()
forall a b. b -> Either a b
Right ()
      ScriptDataRangeError
err:[ScriptDataRangeError]
_ -> ScriptDataRangeError -> Either ScriptDataRangeError ()
forall a b. a -> Either a b
Left ScriptDataRangeError
err
  where
    -- collect all errors in a monoidal fold style:
    collect :: ScriptData -> [ScriptDataRangeError]
collect (ScriptDataNumber Integer
n) =
        [ Integer -> ScriptDataRangeError
ScriptDataNumberOutOfRange Integer
n
        |    Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>         Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64)
          Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer -> Integer
forall a. Num a => a -> a
negate (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64))
        ]
    collect (ScriptDataBytes ByteString
bs) =
        [ Int -> ScriptDataRangeError
ScriptDataBytesTooLong Int
len
        | let len :: Int
len = ByteString -> Int
BS.length ByteString
bs
        , Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
scriptDataByteStringMaxLength
        ]
    collect (ScriptDataList [ScriptData]
xs) =
        (ScriptData -> [ScriptDataRangeError])
-> [ScriptData] -> [ScriptDataRangeError]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ScriptData -> [ScriptDataRangeError]
collect [ScriptData]
xs

    collect (ScriptDataMap [(ScriptData, ScriptData)]
kvs) =
        ((ScriptData, ScriptData) -> [ScriptDataRangeError])
-> [(ScriptData, ScriptData)] -> [ScriptDataRangeError]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(ScriptData
k, ScriptData
v) -> ScriptData -> [ScriptDataRangeError]
collect ScriptData
k
                         [ScriptDataRangeError]
-> [ScriptDataRangeError] -> [ScriptDataRangeError]
forall a. Semigroup a => a -> a -> a
<> ScriptData -> [ScriptDataRangeError]
collect ScriptData
v)
                [(ScriptData, ScriptData)]
kvs

    collect (ScriptDataConstructor Integer
n [ScriptData]
xs) =
        [ Integer -> ScriptDataRangeError
ScriptDataConstructorOutOfRange Integer
n
        | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64) Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 ]
     [ScriptDataRangeError]
-> [ScriptDataRangeError] -> [ScriptDataRangeError]
forall a. Semigroup a => a -> a -> a
<> (ScriptData -> [ScriptDataRangeError])
-> [ScriptData] -> [ScriptDataRangeError]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ScriptData -> [ScriptDataRangeError]
collect [ScriptData]
xs


-- | The maximum length of a script data byte string value.
scriptDataByteStringMaxLength :: Int
scriptDataByteStringMaxLength :: Int
scriptDataByteStringMaxLength = Int
64


-- | An error in script data due to an out-of-range value.
--
data ScriptDataRangeError =

    -- | The number is outside the maximum range of @-2^64-1 .. 2^64-1@.
    --
    ScriptDataNumberOutOfRange !Integer

    -- | The number is outside the maximum range of @-2^64-1 .. 2^64-1@.
    --
  | ScriptDataConstructorOutOfRange !Integer

    -- | The length of a byte string metadatum value exceeds the maximum of
    -- 64 bytes.
    --
  | ScriptDataBytesTooLong !Int
  deriving (ScriptDataRangeError -> ScriptDataRangeError -> Bool
(ScriptDataRangeError -> ScriptDataRangeError -> Bool)
-> (ScriptDataRangeError -> ScriptDataRangeError -> Bool)
-> Eq ScriptDataRangeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptDataRangeError -> ScriptDataRangeError -> Bool
$c/= :: ScriptDataRangeError -> ScriptDataRangeError -> Bool
== :: ScriptDataRangeError -> ScriptDataRangeError -> Bool
$c== :: ScriptDataRangeError -> ScriptDataRangeError -> Bool
Eq, Int -> ScriptDataRangeError -> ShowS
[ScriptDataRangeError] -> ShowS
ScriptDataRangeError -> String
(Int -> ScriptDataRangeError -> ShowS)
-> (ScriptDataRangeError -> String)
-> ([ScriptDataRangeError] -> ShowS)
-> Show ScriptDataRangeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptDataRangeError] -> ShowS
$cshowList :: [ScriptDataRangeError] -> ShowS
show :: ScriptDataRangeError -> String
$cshow :: ScriptDataRangeError -> String
showsPrec :: Int -> ScriptDataRangeError -> ShowS
$cshowsPrec :: Int -> ScriptDataRangeError -> ShowS
Show)

instance Error ScriptDataRangeError where
  displayError :: ScriptDataRangeError -> String
displayError (ScriptDataNumberOutOfRange Integer
n) =
      String
"Number in script data value "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
n
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is outside the range -(2^64-1) .. 2^64-1."
  displayError (ScriptDataConstructorOutOfRange Integer
n) =
      String
"Constructor numbers in script data value "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Show a => a -> String
show Integer
n
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is outside the range 0 .. 2^64-1."
  displayError (ScriptDataBytesTooLong Int
actualLen) =
      String
"Byte strings in script data must consist of at most "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
scriptDataByteStringMaxLength
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" bytes, but it consists of "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
actualLen
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" bytes."


-- ----------------------------------------------------------------------------
-- JSON conversion
--

-- | Script data is similar to JSON but not exactly the same. It has some
-- deliberate limitations such as no support for floating point numbers or
-- special forms for null or boolean values. It also has limitations on the
-- length of strings. On the other hand, unlike JSON, it distinguishes between
-- byte strings and text strings. It also supports any value as map keys rather
-- than just string. It also supports alternatives \/ tagged unions, used for
-- representing constructors for Plutus data values.
--
-- We provide two different mappings between script data and JSON, useful
-- for different purposes:
--
-- 1. A mapping that allows almost any JSON value to be converted into script
--    data. This does not require a specific JSON schema for the input. It does
--    not expose the full representation capability of script data.
--
-- 2. A mapping that exposes the full representation capability of script data,
--    but relies on a specific JSON schema for the input JSON.
--
-- In the \"no schema"\ mapping, the idea is that (almost) any JSON can be
-- turned into script data and then converted back, without loss. That is, we
-- can round-trip the JSON.
--
-- The subset of JSON supported is all JSON except:
-- * No null or bool values
-- * No floating point, only integers in the range of a 64bit signed integer
-- * A limitation on string lengths
--
-- The approach for this mapping is to use whichever representation as script
-- data is most compact. In particular:
--
-- * JSON lists and maps represented as CBOR lists and maps
-- * JSON strings represented as CBOR strings
-- * JSON hex strings with \"0x\" prefix represented as CBOR byte strings
-- * JSON integer numbers represented as CBOR signed or unsigned numbers
-- * JSON maps with string keys that parse as numbers or hex byte strings,
--   represented as CBOR map keys that are actually numbers or byte strings.
--
-- The string length limit depends on whether the hex string representation
-- is used or not. For text strings the limit is 64 bytes for the UTF8
-- representation of the text string. For byte strings the limit is 64 bytes
-- for the raw byte form (ie not the input hex, but after hex decoding).
--
-- In the \"detailed schema\" mapping, the idea is that we expose the full
-- representation capability of the script data in the form of a JSON schema.
-- This means the full representation is available and can be controlled
-- precisely. It also means any script data can be converted into the JSON and
-- back without loss. That is we can round-trip the script data via the JSON and
-- also round-trip schema-compliant JSON via script data.
--
data ScriptDataJsonSchema =

       -- | Use the \"no schema\" mapping between JSON and script data as
       -- described above.
       ScriptDataJsonNoSchema

       -- | Use the \"detailed schema\" mapping between JSON and script data as
       -- described above.
     | ScriptDataJsonDetailedSchema
  deriving (ScriptDataJsonSchema -> ScriptDataJsonSchema -> Bool
(ScriptDataJsonSchema -> ScriptDataJsonSchema -> Bool)
-> (ScriptDataJsonSchema -> ScriptDataJsonSchema -> Bool)
-> Eq ScriptDataJsonSchema
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptDataJsonSchema -> ScriptDataJsonSchema -> Bool
$c/= :: ScriptDataJsonSchema -> ScriptDataJsonSchema -> Bool
== :: ScriptDataJsonSchema -> ScriptDataJsonSchema -> Bool
$c== :: ScriptDataJsonSchema -> ScriptDataJsonSchema -> Bool
Eq, Int -> ScriptDataJsonSchema -> ShowS
[ScriptDataJsonSchema] -> ShowS
ScriptDataJsonSchema -> String
(Int -> ScriptDataJsonSchema -> ShowS)
-> (ScriptDataJsonSchema -> String)
-> ([ScriptDataJsonSchema] -> ShowS)
-> Show ScriptDataJsonSchema
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptDataJsonSchema] -> ShowS
$cshowList :: [ScriptDataJsonSchema] -> ShowS
show :: ScriptDataJsonSchema -> String
$cshow :: ScriptDataJsonSchema -> String
showsPrec :: Int -> ScriptDataJsonSchema -> ShowS
$cshowsPrec :: Int -> ScriptDataJsonSchema -> ShowS
Show)


-- | Convert a value from JSON into script data, using the given choice of
-- mapping between JSON and script data.
--
-- This may fail with a conversion error if the JSON is outside the supported
-- subset for the chosen mapping. See 'ScriptDataJsonSchema' for the details.
--
scriptDataFromJson :: ScriptDataJsonSchema
                   -> Aeson.Value
                   -> Either ScriptDataJsonError ScriptData
scriptDataFromJson :: ScriptDataJsonSchema
-> Value -> Either ScriptDataJsonError ScriptData
scriptDataFromJson ScriptDataJsonSchema
schema Value
v = do
    ScriptData
d <- (ScriptDataJsonSchemaError -> ScriptDataJsonError)
-> Either ScriptDataJsonSchemaError ScriptData
-> Either ScriptDataJsonError ScriptData
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Value -> ScriptDataJsonSchemaError -> ScriptDataJsonError
ScriptDataJsonSchemaError Value
v) (Value -> Either ScriptDataJsonSchemaError ScriptData
scriptDataFromJson' Value
v)
    (ScriptDataRangeError -> ScriptDataJsonError)
-> Either ScriptDataRangeError () -> Either ScriptDataJsonError ()
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Value -> ScriptDataRangeError -> ScriptDataJsonError
ScriptDataRangeError Value
v) (ScriptData -> Either ScriptDataRangeError ()
validateScriptData ScriptData
d)
    ScriptData -> Either ScriptDataJsonError ScriptData
forall (m :: * -> *) a. Monad m => a -> m a
return ScriptData
d
  where
    scriptDataFromJson' :: Value -> Either ScriptDataJsonSchemaError ScriptData
scriptDataFromJson' =
      case ScriptDataJsonSchema
schema of
        ScriptDataJsonSchema
ScriptDataJsonNoSchema       -> Value -> Either ScriptDataJsonSchemaError ScriptData
scriptDataFromJsonNoSchema
        ScriptDataJsonSchema
ScriptDataJsonDetailedSchema -> Value -> Either ScriptDataJsonSchemaError ScriptData
scriptDataFromJsonDetailedSchema



-- | Convert a script data value into JSON , using the given choice of mapping
-- between JSON and script data.
--
-- This conversion is total but is not necessarily invertible.
-- See 'ScriptDataJsonSchema' for the details.
--
scriptDataToJson :: ScriptDataJsonSchema
                 -> ScriptData
                 -> Aeson.Value
scriptDataToJson :: ScriptDataJsonSchema -> ScriptData -> Value
scriptDataToJson ScriptDataJsonSchema
schema =
    case ScriptDataJsonSchema
schema of
      ScriptDataJsonSchema
ScriptDataJsonNoSchema       -> ScriptData -> Value
scriptDataToJsonNoSchema
      ScriptDataJsonSchema
ScriptDataJsonDetailedSchema -> ScriptData -> Value
scriptDataToJsonDetailedSchema


-- ----------------------------------------------------------------------------
-- JSON conversion using the the "no schema" style
--

scriptDataToJsonNoSchema :: ScriptData -> Aeson.Value
scriptDataToJsonNoSchema :: ScriptData -> Value
scriptDataToJsonNoSchema = ScriptData -> Value
conv
  where
    conv :: ScriptData -> Aeson.Value
    conv :: ScriptData -> Value
conv (ScriptDataNumber Integer
n) = Scientific -> Value
Aeson.Number (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
n)
    conv (ScriptDataBytes ByteString
bs)
      | Right Text
s <- ByteString -> Either UnicodeException Text
Text.decodeUtf8' ByteString
bs
      , (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
Char.isPrint Text
s
      = Text -> Value
Aeson.String Text
s

      | Bool
otherwise
      = Text -> Value
Aeson.String (Text
bytesPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
Text.decodeLatin1 (ByteString -> ByteString
Base16.encode ByteString
bs))

    conv (ScriptDataList  [ScriptData]
vs) = Array -> Value
Aeson.Array ([Value] -> Array
forall a. [a] -> Vector a
Vector.fromList ((ScriptData -> Value) -> [ScriptData] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ScriptData -> Value
conv [ScriptData]
vs))
    conv (ScriptDataMap  [(ScriptData, ScriptData)]
kvs) = [Pair] -> Value
Aeson.object
                                  [ (ScriptData -> Key
convKey ScriptData
k, ScriptData -> Value
conv ScriptData
v)
                                  | (ScriptData
k, ScriptData
v) <- [(ScriptData, ScriptData)]
kvs ]

    conv (ScriptDataConstructor Integer
n [ScriptData]
vs) =
        Array -> Value
Aeson.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$
          [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList
           [ Scientific -> Value
Aeson.Number (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
n)
           , Array -> Value
Aeson.Array ([Value] -> Array
forall a. [a] -> Vector a
Vector.fromList ((ScriptData -> Value) -> [ScriptData] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ScriptData -> Value
conv [ScriptData]
vs))
           ]


    -- Script data allows any value as a key, not just string as JSON does.
    -- For simple types we just convert them to string directly.
    -- For structured keys we render them as JSON and use that as the string.
    convKey :: ScriptData -> Aeson.Key
    convKey :: ScriptData -> Key
convKey (ScriptDataNumber Integer
n) = Text -> Key
Aeson.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (Integer -> String
forall a. Show a => a -> String
show Integer
n)
    convKey (ScriptDataBytes ByteString
bs) = Text -> Key
Aeson.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ Text
bytesPrefix
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
Text.decodeLatin1 (ByteString -> ByteString
Base16.encode ByteString
bs)
    convKey ScriptData
v                    = Text -> Key
Aeson.fromText
                                 (Text -> Key) -> (ScriptData -> Text) -> ScriptData -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.Lazy.toStrict
                                 (Text -> Text) -> (ScriptData -> Text) -> ScriptData -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Text
forall a. ToJSON a => a -> Text
Aeson.Text.encodeToLazyText
                                 (Value -> Text) -> (ScriptData -> Value) -> ScriptData -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptData -> Value
conv
                                 (ScriptData -> Key) -> ScriptData -> Key
forall a b. (a -> b) -> a -> b
$ ScriptData
v

scriptDataFromJsonNoSchema :: Aeson.Value
                           -> Either ScriptDataJsonSchemaError
                                     ScriptData
scriptDataFromJsonNoSchema :: Value -> Either ScriptDataJsonSchemaError ScriptData
scriptDataFromJsonNoSchema = Value -> Either ScriptDataJsonSchemaError ScriptData
conv
  where
    conv :: Aeson.Value
         -> Either ScriptDataJsonSchemaError ScriptData
    conv :: Value -> Either ScriptDataJsonSchemaError ScriptData
conv Value
Aeson.Null   = ScriptDataJsonSchemaError
-> Either ScriptDataJsonSchemaError ScriptData
forall a b. a -> Either a b
Left ScriptDataJsonSchemaError
ScriptDataJsonNullNotAllowed
    conv Aeson.Bool{} = ScriptDataJsonSchemaError
-> Either ScriptDataJsonSchemaError ScriptData
forall a b. a -> Either a b
Left ScriptDataJsonSchemaError
ScriptDataJsonBoolNotAllowed

    conv (Aeson.Number Scientific
d) =
      case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
d :: Either Double Integer of
        Left  Double
n -> ScriptDataJsonSchemaError
-> Either ScriptDataJsonSchemaError ScriptData
forall a b. a -> Either a b
Left (Double -> ScriptDataJsonSchemaError
ScriptDataJsonNumberNotInteger Double
n)
        Right Integer
n -> ScriptData -> Either ScriptDataJsonSchemaError ScriptData
forall a b. b -> Either a b
Right (Integer -> ScriptData
ScriptDataNumber Integer
n)

    conv (Aeson.String Text
s)
      | Just Text
s' <- Text -> Text -> Maybe Text
Text.stripPrefix Text
bytesPrefix Text
s
      , let bs' :: ByteString
bs' = Text -> ByteString
Text.encodeUtf8 Text
s'
      , Right ByteString
bs <- ByteString -> Either String ByteString
Base16.decode ByteString
bs'
      , Bool -> Bool
not ((Char -> Bool) -> ByteString -> Bool
BSC.any (\Char
c -> Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F') ByteString
bs')
      = ScriptData -> Either ScriptDataJsonSchemaError ScriptData
forall a b. b -> Either a b
Right (ByteString -> ScriptData
ScriptDataBytes ByteString
bs)

      | Bool
otherwise
      = ScriptData -> Either ScriptDataJsonSchemaError ScriptData
forall a b. b -> Either a b
Right (ByteString -> ScriptData
ScriptDataBytes (Text -> ByteString
Text.encodeUtf8 Text
s))

    conv (Aeson.Array Array
vs) =
        ([ScriptData] -> ScriptData)
-> Either ScriptDataJsonSchemaError [ScriptData]
-> Either ScriptDataJsonSchemaError ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ScriptData] -> ScriptData
ScriptDataList
      (Either ScriptDataJsonSchemaError [ScriptData]
 -> Either ScriptDataJsonSchemaError ScriptData)
-> ([Value] -> Either ScriptDataJsonSchemaError [ScriptData])
-> [Value]
-> Either ScriptDataJsonSchemaError ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Either ScriptDataJsonSchemaError ScriptData)
-> [Value] -> Either ScriptDataJsonSchemaError [ScriptData]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Either ScriptDataJsonSchemaError ScriptData
conv
      ([Value] -> Either ScriptDataJsonSchemaError ScriptData)
-> [Value] -> Either ScriptDataJsonSchemaError ScriptData
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
vs

    conv (Aeson.Object Object
kvs) =
        ([(ScriptData, ScriptData)] -> ScriptData)
-> Either ScriptDataJsonSchemaError [(ScriptData, ScriptData)]
-> Either ScriptDataJsonSchemaError ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ScriptData, ScriptData)] -> ScriptData
ScriptDataMap
      (Either ScriptDataJsonSchemaError [(ScriptData, ScriptData)]
 -> Either ScriptDataJsonSchemaError ScriptData)
-> ([Pair]
    -> Either ScriptDataJsonSchemaError [(ScriptData, ScriptData)])
-> [Pair]
-> Either ScriptDataJsonSchemaError ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Value)
 -> Either ScriptDataJsonSchemaError (ScriptData, ScriptData))
-> [(Text, Value)]
-> Either ScriptDataJsonSchemaError [(ScriptData, ScriptData)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\(Text
k,Value
v) -> (,) (Text -> ScriptData
convKey Text
k) (ScriptData -> (ScriptData, ScriptData))
-> Either ScriptDataJsonSchemaError ScriptData
-> Either ScriptDataJsonSchemaError (ScriptData, ScriptData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either ScriptDataJsonSchemaError ScriptData
conv Value
v)
      ([(Text, Value)]
 -> Either ScriptDataJsonSchemaError [(ScriptData, ScriptData)])
-> ([Pair] -> [(Text, Value)])
-> [Pair]
-> Either ScriptDataJsonSchemaError [(ScriptData, ScriptData)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Value) -> Text) -> [(Text, Value)] -> [(Text, Value)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Text, Value) -> Text
forall a b. (a, b) -> a
fst
      ([(Text, Value)] -> [(Text, Value)])
-> ([Pair] -> [(Text, Value)]) -> [Pair] -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pair -> (Text, Value)) -> [Pair] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key -> Text) -> Pair -> (Text, Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Key -> Text
Aeson.toText)
      ([Pair] -> Either ScriptDataJsonSchemaError ScriptData)
-> [Pair] -> Either ScriptDataJsonSchemaError ScriptData
forall a b. (a -> b) -> a -> b
$ Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
kvs

    convKey :: Text -> ScriptData
    convKey :: Text -> ScriptData
convKey Text
s =
      ScriptData -> Maybe ScriptData -> ScriptData
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> ScriptData
ScriptDataBytes (Text -> ByteString
Text.encodeUtf8 Text
s)) (Maybe ScriptData -> ScriptData) -> Maybe ScriptData -> ScriptData
forall a b. (a -> b) -> a -> b
$
      Parser ScriptData -> Text -> Maybe ScriptData
forall a. Parser a -> Text -> Maybe a
parseAll (((Integer -> ScriptData)
-> Parser ByteString Integer -> Parser ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> ScriptData
ScriptDataNumber Parser ByteString Integer
pSigned Parser ScriptData -> Parser ByteString () -> Parser ScriptData
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Atto.endOfInput)
            Parser ScriptData -> Parser ScriptData -> Parser ScriptData
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((ByteString -> ScriptData)
-> Parser ByteString ByteString -> Parser ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ScriptData
ScriptDataBytes  Parser ByteString ByteString
pBytes  Parser ScriptData -> Parser ByteString () -> Parser ScriptData
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Atto.endOfInput)) Text
s

-- | JSON strings that are base16 encoded and prefixed with 'bytesPrefix' will
-- be encoded as CBOR bytestrings.
bytesPrefix :: Text
bytesPrefix :: Text
bytesPrefix = Text
"0x"


-- ----------------------------------------------------------------------------
-- JSON conversion using the "detailed schema" style
--

scriptDataToJsonDetailedSchema :: ScriptData -> Aeson.Value
scriptDataToJsonDetailedSchema :: ScriptData -> Value
scriptDataToJsonDetailedSchema = ScriptData -> Value
conv
  where
    conv :: ScriptData -> Aeson.Value
    conv :: ScriptData -> Value
conv (ScriptDataNumber Integer
n) = Key -> Value -> Value
singleFieldObject Key
"int"
                              (Value -> Value) -> (Scientific -> Value) -> Scientific -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Value
Aeson.Number
                              (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
n
    conv (ScriptDataBytes ByteString
bs) = Key -> Value -> Value
singleFieldObject Key
"bytes"
                              (Value -> Value) -> (Text -> Value) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
Aeson.String
                              (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeLatin1 (ByteString -> ByteString
Base16.encode ByteString
bs)
    conv (ScriptDataList  [ScriptData]
vs) = Key -> Value -> Value
singleFieldObject Key
"list"
                              (Value -> Value) -> (Array -> Value) -> Array -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Value
Aeson.Array
                              (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList ((ScriptData -> Value) -> [ScriptData] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ScriptData -> Value
conv [ScriptData]
vs)
    conv (ScriptDataMap  [(ScriptData, ScriptData)]
kvs) = Key -> Value -> Value
singleFieldObject Key
"map"
                              (Value -> Value) -> (Array -> Value) -> Array -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Value
Aeson.Array
                              (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList
                                  [ [Pair] -> Value
Aeson.object [ (Key
"k", ScriptData -> Value
conv ScriptData
k), (Key
"v", ScriptData -> Value
conv ScriptData
v) ]
                                  | (ScriptData
k, ScriptData
v) <- [(ScriptData, ScriptData)]
kvs ]

    conv (ScriptDataConstructor Integer
n [ScriptData]
vs) =
      [Pair] -> Value
Aeson.object
        [ (Key
"constructor", Scientific -> Value
Aeson.Number (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
n))
        , (Key
"fields",      Array -> Value
Aeson.Array ([Value] -> Array
forall a. [a] -> Vector a
Vector.fromList ((ScriptData -> Value) -> [ScriptData] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ScriptData -> Value
conv [ScriptData]
vs)))
        ]

    singleFieldObject :: Key -> Value -> Value
singleFieldObject Key
name Value
v = [Pair] -> Value
Aeson.object [(Key
name, Value
v)]


scriptDataFromJsonDetailedSchema :: Aeson.Value
                                 -> Either ScriptDataJsonSchemaError
                                           ScriptData
scriptDataFromJsonDetailedSchema :: Value -> Either ScriptDataJsonSchemaError ScriptData
scriptDataFromJsonDetailedSchema = Value -> Either ScriptDataJsonSchemaError ScriptData
conv
  where
    conv :: Aeson.Value
         -> Either ScriptDataJsonSchemaError ScriptData
    conv :: Value -> Either ScriptDataJsonSchemaError ScriptData
conv (Aeson.Object Object
m) =
      case [Pair] -> [Pair]
forall a. Ord a => [a] -> [a]
List.sort ([Pair] -> [Pair]) -> [Pair] -> [Pair]
forall a b. (a -> b) -> a -> b
$ Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
m of
        [(Key
"int", Aeson.Number Scientific
d)] ->
          case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
d :: Either Double Integer of
            Left  Double
n -> ScriptDataJsonSchemaError
-> Either ScriptDataJsonSchemaError ScriptData
forall a b. a -> Either a b
Left (Double -> ScriptDataJsonSchemaError
ScriptDataJsonNumberNotInteger Double
n)
            Right Integer
n -> ScriptData -> Either ScriptDataJsonSchemaError ScriptData
forall a b. b -> Either a b
Right (Integer -> ScriptData
ScriptDataNumber Integer
n)

        [(Key
"bytes", Aeson.String Text
s)]
          | Right ByteString
bs <- ByteString -> Either String ByteString
Base16.decode (Text -> ByteString
Text.encodeUtf8 Text
s)
          -> ScriptData -> Either ScriptDataJsonSchemaError ScriptData
forall a b. b -> Either a b
Right (ByteString -> ScriptData
ScriptDataBytes ByteString
bs)

        [(Key
"list", Aeson.Array Array
vs)] ->
            ([ScriptData] -> ScriptData)
-> Either ScriptDataJsonSchemaError [ScriptData]
-> Either ScriptDataJsonSchemaError ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ScriptData] -> ScriptData
ScriptDataList
          (Either ScriptDataJsonSchemaError [ScriptData]
 -> Either ScriptDataJsonSchemaError ScriptData)
-> ([Value] -> Either ScriptDataJsonSchemaError [ScriptData])
-> [Value]
-> Either ScriptDataJsonSchemaError ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Either ScriptDataJsonSchemaError ScriptData)
-> [Value] -> Either ScriptDataJsonSchemaError [ScriptData]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Either ScriptDataJsonSchemaError ScriptData
conv
          ([Value] -> Either ScriptDataJsonSchemaError ScriptData)
-> [Value] -> Either ScriptDataJsonSchemaError ScriptData
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
vs

        [(Key
"map", Aeson.Array Array
kvs)] ->
            ([(ScriptData, ScriptData)] -> ScriptData)
-> Either ScriptDataJsonSchemaError [(ScriptData, ScriptData)]
-> Either ScriptDataJsonSchemaError ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(ScriptData, ScriptData)] -> ScriptData
ScriptDataMap
          (Either ScriptDataJsonSchemaError [(ScriptData, ScriptData)]
 -> Either ScriptDataJsonSchemaError ScriptData)
-> ([Value]
    -> Either ScriptDataJsonSchemaError [(ScriptData, ScriptData)])
-> [Value]
-> Either ScriptDataJsonSchemaError ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value
 -> Either ScriptDataJsonSchemaError (ScriptData, ScriptData))
-> [Value]
-> Either ScriptDataJsonSchemaError [(ScriptData, ScriptData)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Either ScriptDataJsonSchemaError (ScriptData, ScriptData)
convKeyValuePair
          ([Value] -> Either ScriptDataJsonSchemaError ScriptData)
-> [Value] -> Either ScriptDataJsonSchemaError ScriptData
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
kvs

        [(Key
"constructor", Aeson.Number Scientific
d),
         (Key
"fields",      Aeson.Array Array
vs)] ->
          case Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
d :: Either Double Integer of
            Left  Double
n -> ScriptDataJsonSchemaError
-> Either ScriptDataJsonSchemaError ScriptData
forall a b. a -> Either a b
Left (Double -> ScriptDataJsonSchemaError
ScriptDataJsonNumberNotInteger Double
n)
            Right Integer
n -> ([ScriptData] -> ScriptData)
-> Either ScriptDataJsonSchemaError [ScriptData]
-> Either ScriptDataJsonSchemaError ScriptData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> [ScriptData] -> ScriptData
ScriptDataConstructor Integer
n)
                     (Either ScriptDataJsonSchemaError [ScriptData]
 -> Either ScriptDataJsonSchemaError ScriptData)
-> ([Value] -> Either ScriptDataJsonSchemaError [ScriptData])
-> [Value]
-> Either ScriptDataJsonSchemaError ScriptData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Either ScriptDataJsonSchemaError ScriptData)
-> [Value] -> Either ScriptDataJsonSchemaError [ScriptData]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value -> Either ScriptDataJsonSchemaError ScriptData
conv
                     ([Value] -> Either ScriptDataJsonSchemaError ScriptData)
-> [Value] -> Either ScriptDataJsonSchemaError ScriptData
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
vs

        (Key
key, Value
v):[Pair]
_ | Key
key Key -> [Key] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key
"int", Key
"bytes", Key
"list", Key
"map", Key
"constructor"] ->
            ScriptDataJsonSchemaError
-> Either ScriptDataJsonSchemaError ScriptData
forall a b. a -> Either a b
Left (Text -> Value -> ScriptDataJsonSchemaError
ScriptDataJsonTypeMismatch (Key -> Text
Aeson.toText Key
key) Value
v)

        [Pair]
kvs -> ScriptDataJsonSchemaError
-> Either ScriptDataJsonSchemaError ScriptData
forall a b. a -> Either a b
Left ([(Text, Value)] -> ScriptDataJsonSchemaError
ScriptDataJsonBadObject ([(Text, Value)] -> ScriptDataJsonSchemaError)
-> [(Text, Value)] -> ScriptDataJsonSchemaError
forall a b. (a -> b) -> a -> b
$ (Key -> Text) -> Pair -> (Text, Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Key -> Text
Aeson.toText (Pair -> (Text, Value)) -> [Pair] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pair]
kvs)

    conv Value
v = ScriptDataJsonSchemaError
-> Either ScriptDataJsonSchemaError ScriptData
forall a b. a -> Either a b
Left (Value -> ScriptDataJsonSchemaError
ScriptDataJsonNotObject Value
v)

    convKeyValuePair :: Aeson.Value
                     -> Either ScriptDataJsonSchemaError
                               (ScriptData, ScriptData)
    convKeyValuePair :: Value -> Either ScriptDataJsonSchemaError (ScriptData, ScriptData)
convKeyValuePair (Aeson.Object Object
m)
      | Object -> Int
forall v. KeyMap v -> Int
KeyMap.size Object
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
      , Just Value
k <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"k" Object
m
      , Just Value
v <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"v" Object
m
      = (,) (ScriptData -> ScriptData -> (ScriptData, ScriptData))
-> Either ScriptDataJsonSchemaError ScriptData
-> Either
     ScriptDataJsonSchemaError (ScriptData -> (ScriptData, ScriptData))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either ScriptDataJsonSchemaError ScriptData
conv Value
k Either
  ScriptDataJsonSchemaError (ScriptData -> (ScriptData, ScriptData))
-> Either ScriptDataJsonSchemaError ScriptData
-> Either ScriptDataJsonSchemaError (ScriptData, ScriptData)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either ScriptDataJsonSchemaError ScriptData
conv Value
v

    convKeyValuePair Value
v = ScriptDataJsonSchemaError
-> Either ScriptDataJsonSchemaError (ScriptData, ScriptData)
forall a b. a -> Either a b
Left (Value -> ScriptDataJsonSchemaError
ScriptDataJsonBadMapPair Value
v)


-- ----------------------------------------------------------------------------
-- Shared JSON conversion error types
--

data ScriptDataJsonError =
       ScriptDataJsonSchemaError !Aeson.Value !ScriptDataJsonSchemaError
     | ScriptDataRangeError      !Aeson.Value !ScriptDataRangeError
  deriving (ScriptDataJsonError -> ScriptDataJsonError -> Bool
(ScriptDataJsonError -> ScriptDataJsonError -> Bool)
-> (ScriptDataJsonError -> ScriptDataJsonError -> Bool)
-> Eq ScriptDataJsonError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptDataJsonError -> ScriptDataJsonError -> Bool
$c/= :: ScriptDataJsonError -> ScriptDataJsonError -> Bool
== :: ScriptDataJsonError -> ScriptDataJsonError -> Bool
$c== :: ScriptDataJsonError -> ScriptDataJsonError -> Bool
Eq, Int -> ScriptDataJsonError -> ShowS
[ScriptDataJsonError] -> ShowS
ScriptDataJsonError -> String
(Int -> ScriptDataJsonError -> ShowS)
-> (ScriptDataJsonError -> String)
-> ([ScriptDataJsonError] -> ShowS)
-> Show ScriptDataJsonError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptDataJsonError] -> ShowS
$cshowList :: [ScriptDataJsonError] -> ShowS
show :: ScriptDataJsonError -> String
$cshow :: ScriptDataJsonError -> String
showsPrec :: Int -> ScriptDataJsonError -> ShowS
$cshowsPrec :: Int -> ScriptDataJsonError -> ShowS
Show)

data ScriptDataJsonSchemaError =
       -- Only used for 'ScriptDataJsonNoSchema'
       ScriptDataJsonNullNotAllowed
     | ScriptDataJsonBoolNotAllowed

       -- Used by both mappings
     | ScriptDataJsonNumberNotInteger !Double

       -- Only used for 'ScriptDataJsonDetailedSchema'
     | ScriptDataJsonNotObject !Aeson.Value
     | ScriptDataJsonBadObject ![(Text, Aeson.Value)]
     | ScriptDataJsonBadMapPair !Aeson.Value
     | ScriptDataJsonTypeMismatch !Text !Aeson.Value
  deriving (ScriptDataJsonSchemaError -> ScriptDataJsonSchemaError -> Bool
(ScriptDataJsonSchemaError -> ScriptDataJsonSchemaError -> Bool)
-> (ScriptDataJsonSchemaError -> ScriptDataJsonSchemaError -> Bool)
-> Eq ScriptDataJsonSchemaError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScriptDataJsonSchemaError -> ScriptDataJsonSchemaError -> Bool
$c/= :: ScriptDataJsonSchemaError -> ScriptDataJsonSchemaError -> Bool
== :: ScriptDataJsonSchemaError -> ScriptDataJsonSchemaError -> Bool
$c== :: ScriptDataJsonSchemaError -> ScriptDataJsonSchemaError -> Bool
Eq, Int -> ScriptDataJsonSchemaError -> ShowS
[ScriptDataJsonSchemaError] -> ShowS
ScriptDataJsonSchemaError -> String
(Int -> ScriptDataJsonSchemaError -> ShowS)
-> (ScriptDataJsonSchemaError -> String)
-> ([ScriptDataJsonSchemaError] -> ShowS)
-> Show ScriptDataJsonSchemaError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptDataJsonSchemaError] -> ShowS
$cshowList :: [ScriptDataJsonSchemaError] -> ShowS
show :: ScriptDataJsonSchemaError -> String
$cshow :: ScriptDataJsonSchemaError -> String
showsPrec :: Int -> ScriptDataJsonSchemaError -> ShowS
$cshowsPrec :: Int -> ScriptDataJsonSchemaError -> ShowS
Show)

instance Error ScriptDataJsonError where
    displayError :: ScriptDataJsonError -> String
displayError (ScriptDataJsonSchemaError Value
v ScriptDataJsonSchemaError
detail) =
        String
"JSON schema error within the script data: "
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ LByteString -> String
LBS.unpack (Value -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode Value
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScriptDataJsonSchemaError -> String
forall e. Error e => e -> String
displayError ScriptDataJsonSchemaError
detail
    displayError (ScriptDataRangeError Value
v ScriptDataRangeError
detail) =
        String
"Value out of range within the script data: "
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ LByteString -> String
LBS.unpack (Value -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode Value
v) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScriptDataRangeError -> String
forall e. Error e => e -> String
displayError ScriptDataRangeError
detail

instance Error ScriptDataJsonSchemaError where
    displayError :: ScriptDataJsonSchemaError -> String
displayError ScriptDataJsonSchemaError
ScriptDataJsonNullNotAllowed =
        String
"JSON null values are not supported."
    displayError ScriptDataJsonSchemaError
ScriptDataJsonBoolNotAllowed =
        String
"JSON bool values are not supported."
    displayError (ScriptDataJsonNumberNotInteger Double
d) =
        String
"JSON numbers must be integers. Unexpected value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
d
    displayError (ScriptDataJsonNotObject Value
v) =
        String
"JSON object expected. Unexpected value: "
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ LByteString -> String
LBS.unpack (Value -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode Value
v)
    displayError (ScriptDataJsonBadObject [(Text, Value)]
v) =
        String
"JSON object does not match the schema.\nExpected a single field named "
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\"int\", \"bytes\", \"string\", \"list\" or \"map\".\n"
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Unexpected object field(s): "
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ LByteString -> String
LBS.unpack (Object -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode ([Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([Pair] -> Object) -> [Pair] -> Object
forall a b. (a -> b) -> a -> b
$ (Text -> Key) -> (Text, Value) -> Pair
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Key
Aeson.fromText ((Text, Value) -> Pair) -> [(Text, Value)] -> [Pair]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Value)]
v))
    displayError (ScriptDataJsonBadMapPair Value
v) =
        String
"Expected a list of key/value pair { \"k\": ..., \"v\": ... } objects."
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nUnexpected value: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ LByteString -> String
LBS.unpack (Value -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode Value
v)
    displayError (ScriptDataJsonTypeMismatch Text
k Value
v) =
        String
"The value in the field " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not have the type "
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"required by the schema.\nUnexpected value: "
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ LByteString -> String
LBS.unpack (Value -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode Value
v)