{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

-- | Metadata embedded in transactions
--
module Cardano.Api.TxMetadata (

    -- * Types
    TxMetadata (TxMetadata),

    -- * Constructing metadata
    TxMetadataValue(..),
    makeTransactionMetadata,

    -- * Validating metadata
    validateTxMetadata,
    TxMetadataRangeError (..),

    -- * Conversion to\/from JSON
    TxMetadataJsonSchema (..),
    metadataFromJson,
    metadataToJson,
    metadataValueToJsonNoSchema,
    TxMetadataJsonError (..),
    TxMetadataJsonSchemaError (..),

    -- * Internal conversion functions
    toShelleyMetadata,
    fromShelleyMetadata,
    toShelleyMetadatum,
    fromShelleyMetadatum,

    -- * Shared parsing utils
    parseAll,
    pUnsigned,
    pSigned,
    pBytes,

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

import           Cardano.Api.Eras
import           Cardano.Api.Error
import           Cardano.Api.HasTypeProxy
import           Cardano.Api.SerialiseCBOR
import qualified Cardano.Binary as CBOR
import qualified Cardano.Ledger.Shelley.Metadata as Shelley
import           Control.Applicative (Alternative (..))
import           Control.Monad (guard, when)
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           Data.Bifunctor (first)
import           Data.ByteString (ByteString)
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.List as List
import qualified Data.Map.Lazy as Map.Lazy
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromMaybe)
import qualified Data.Scientific as Scientific
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

{- HLINT ignore "Use lambda-case" -}

-- ----------------------------------------------------------------------------
-- TxMetadata types
--

newtype TxMetadata = TxMetadata (Map Word64 TxMetadataValue)
    deriving (TxMetadata -> TxMetadata -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxMetadata -> TxMetadata -> Bool
$c/= :: TxMetadata -> TxMetadata -> Bool
== :: TxMetadata -> TxMetadata -> Bool
$c== :: TxMetadata -> TxMetadata -> Bool
Eq, Int -> TxMetadata -> ShowS
[TxMetadata] -> ShowS
TxMetadata -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxMetadata] -> ShowS
$cshowList :: [TxMetadata] -> ShowS
show :: TxMetadata -> String
$cshow :: TxMetadata -> String
showsPrec :: Int -> TxMetadata -> ShowS
$cshowsPrec :: Int -> TxMetadata -> ShowS
Show)

data TxMetadataValue = TxMetaMap    [(TxMetadataValue, TxMetadataValue)]
                     | TxMetaList   [TxMetadataValue]
                     | TxMetaNumber Integer -- -2^64 .. 2^64-1
                     | TxMetaBytes  ByteString
                     | TxMetaText   Text
    deriving (TxMetadataValue -> TxMetadataValue -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxMetadataValue -> TxMetadataValue -> Bool
$c/= :: TxMetadataValue -> TxMetadataValue -> Bool
== :: TxMetadataValue -> TxMetadataValue -> Bool
$c== :: TxMetadataValue -> TxMetadataValue -> Bool
Eq, Eq TxMetadataValue
TxMetadataValue -> TxMetadataValue -> Bool
TxMetadataValue -> TxMetadataValue -> Ordering
TxMetadataValue -> TxMetadataValue -> TxMetadataValue
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 :: TxMetadataValue -> TxMetadataValue -> TxMetadataValue
$cmin :: TxMetadataValue -> TxMetadataValue -> TxMetadataValue
max :: TxMetadataValue -> TxMetadataValue -> TxMetadataValue
$cmax :: TxMetadataValue -> TxMetadataValue -> TxMetadataValue
>= :: TxMetadataValue -> TxMetadataValue -> Bool
$c>= :: TxMetadataValue -> TxMetadataValue -> Bool
> :: TxMetadataValue -> TxMetadataValue -> Bool
$c> :: TxMetadataValue -> TxMetadataValue -> Bool
<= :: TxMetadataValue -> TxMetadataValue -> Bool
$c<= :: TxMetadataValue -> TxMetadataValue -> Bool
< :: TxMetadataValue -> TxMetadataValue -> Bool
$c< :: TxMetadataValue -> TxMetadataValue -> Bool
compare :: TxMetadataValue -> TxMetadataValue -> Ordering
$ccompare :: TxMetadataValue -> TxMetadataValue -> Ordering
Ord, Int -> TxMetadataValue -> ShowS
[TxMetadataValue] -> ShowS
TxMetadataValue -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxMetadataValue] -> ShowS
$cshowList :: [TxMetadataValue] -> ShowS
show :: TxMetadataValue -> String
$cshow :: TxMetadataValue -> String
showsPrec :: Int -> TxMetadataValue -> ShowS
$cshowsPrec :: Int -> TxMetadataValue -> ShowS
Show)
  -- Note the order of constructors is the same as the ledger definitions
  -- so that the Ord instance is consistent with the ledger one.
  -- This is checked by prop_ord_distributive_TxMetadata

-- | Merge metadata maps. When there are clashing entries the left hand side
-- takes precedence.
--
instance Semigroup TxMetadata where
    TxMetadata Map Word64 TxMetadataValue
m1 <> :: TxMetadata -> TxMetadata -> TxMetadata
<> TxMetadata Map Word64 TxMetadataValue
m2 = Map Word64 TxMetadataValue -> TxMetadata
TxMetadata (Map Word64 TxMetadataValue
m1 forall a. Semigroup a => a -> a -> a
<> Map Word64 TxMetadataValue
m2)

instance Monoid TxMetadata where
    mempty :: TxMetadata
mempty = Map Word64 TxMetadataValue -> TxMetadata
TxMetadata forall a. Monoid a => a
mempty

instance HasTypeProxy TxMetadata where
    data AsType TxMetadata = AsTxMetadata
    proxyToAsType :: Proxy TxMetadata -> AsType TxMetadata
proxyToAsType Proxy TxMetadata
_ = AsType TxMetadata
AsTxMetadata

instance SerialiseAsCBOR TxMetadata where
    serialiseToCBOR :: TxMetadata -> ByteString
serialiseToCBOR =
          forall a. ToCBOR a => a -> ByteString
CBOR.serialize'
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall era. Map Word64 Metadatum -> Metadata era
Shelley.Metadata :: Map Word64 Shelley.Metadatum -> Shelley.Metadata ())
        -- The Shelley (Metadata era) is always polymorphic in era,
        -- so we pick the unit type.
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Word64 TxMetadataValue -> Map Word64 Metadatum
toShelleyMetadata
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(TxMetadata Map Word64 TxMetadataValue
m) -> Map Word64 TxMetadataValue
m)

    deserialiseFromCBOR :: AsType TxMetadata -> ByteString -> Either DecoderError TxMetadata
deserialiseFromCBOR AsType TxMetadata
R:AsTypeTxMetadata
AsTxMetadata ByteString
bs =
          Map Word64 TxMetadataValue -> TxMetadata
TxMetadata
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Word64 Metadatum -> Map Word64 TxMetadataValue
fromShelleyMetadata
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Shelley.Metadata Map Word64 Metadatum
m) -> Map Word64 Metadatum
m)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a.
Text
-> (forall s. Decoder s (Annotator a))
-> ByteString
-> Either DecoderError a
CBOR.decodeAnnotator Text
"TxMetadata" forall a s. FromCBOR a => Decoder s a
fromCBOR (ByteString -> ByteString
LBS.fromStrict ByteString
bs)
           :: Either CBOR.DecoderError (Shelley.Metadata ()))
        -- The Shelley (Metadata era) is always polymorphic in era,
        -- so we pick the unit type.

makeTransactionMetadata :: Map Word64 TxMetadataValue -> TxMetadata
makeTransactionMetadata :: Map Word64 TxMetadataValue -> TxMetadata
makeTransactionMetadata = Map Word64 TxMetadataValue -> TxMetadata
TxMetadata


-- ----------------------------------------------------------------------------
-- Internal conversion functions
--

toShelleyMetadata :: Map Word64 TxMetadataValue -> Map Word64 Shelley.Metadatum
toShelleyMetadata :: Map Word64 TxMetadataValue -> Map Word64 Metadatum
toShelleyMetadata = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map TxMetadataValue -> Metadatum
toShelleyMetadatum

toShelleyMetadatum :: TxMetadataValue -> Shelley.Metadatum
toShelleyMetadatum :: TxMetadataValue -> Metadatum
toShelleyMetadatum (TxMetaNumber Integer
x) = Integer -> Metadatum
Shelley.I Integer
x
toShelleyMetadatum (TxMetaBytes  ByteString
x) = ByteString -> Metadatum
Shelley.B ByteString
x
toShelleyMetadatum (TxMetaText   Text
x) = Text -> Metadatum
Shelley.S Text
x
toShelleyMetadatum (TxMetaList  [TxMetadataValue]
xs) = [Metadatum] -> Metadatum
Shelley.List
                                        [ TxMetadataValue -> Metadatum
toShelleyMetadatum TxMetadataValue
x | TxMetadataValue
x <- [TxMetadataValue]
xs ]
toShelleyMetadatum (TxMetaMap   [(TxMetadataValue, TxMetadataValue)]
xs) = [(Metadatum, Metadatum)] -> Metadatum
Shelley.Map
                                        [ (TxMetadataValue -> Metadatum
toShelleyMetadatum TxMetadataValue
k,
                                           TxMetadataValue -> Metadatum
toShelleyMetadatum TxMetadataValue
v)
                                        | (TxMetadataValue
k,TxMetadataValue
v) <- [(TxMetadataValue, TxMetadataValue)]
xs ]

fromShelleyMetadata :: Map Word64 Shelley.Metadatum -> Map Word64 TxMetadataValue
fromShelleyMetadata :: Map Word64 Metadatum -> Map Word64 TxMetadataValue
fromShelleyMetadata = forall a b k. (a -> b) -> Map k a -> Map k b
Map.Lazy.map Metadatum -> TxMetadataValue
fromShelleyMetadatum

fromShelleyMetadatum :: Shelley.Metadatum -> TxMetadataValue
fromShelleyMetadatum :: Metadatum -> TxMetadataValue
fromShelleyMetadatum (Shelley.I     Integer
x) = Integer -> TxMetadataValue
TxMetaNumber Integer
x
fromShelleyMetadatum (Shelley.B     ByteString
x) = ByteString -> TxMetadataValue
TxMetaBytes  ByteString
x
fromShelleyMetadatum (Shelley.S     Text
x) = Text -> TxMetadataValue
TxMetaText   Text
x
fromShelleyMetadatum (Shelley.List [Metadatum]
xs) = [TxMetadataValue] -> TxMetadataValue
TxMetaList
                                           [ Metadatum -> TxMetadataValue
fromShelleyMetadatum Metadatum
x | Metadatum
x <- [Metadatum]
xs ]
fromShelleyMetadatum (Shelley.Map  [(Metadatum, Metadatum)]
xs) = [(TxMetadataValue, TxMetadataValue)] -> TxMetadataValue
TxMetaMap
                                           [ (Metadatum -> TxMetadataValue
fromShelleyMetadatum Metadatum
k,
                                              Metadatum -> TxMetadataValue
fromShelleyMetadatum Metadatum
v)
                                           | (Metadatum
k,Metadatum
v) <- [(Metadatum, Metadatum)]
xs ]


-- ----------------------------------------------------------------------------
-- Validate tx metadata
--

-- | Validate transaction metadata. This is for use with existing constructed
-- metadata values, e.g. constructed manually or decoded from CBOR directly.
--
validateTxMetadata :: TxMetadata -> Either [(Word64, TxMetadataRangeError)] ()
validateTxMetadata :: TxMetadata -> Either [(Word64, TxMetadataRangeError)] ()
validateTxMetadata (TxMetadata Map Word64 TxMetadataValue
m) =
    -- Collect all errors and do a top-level check to see if there are any.
    case [ (Word64
k, TxMetadataRangeError
err)
         | (Word64
k, TxMetadataValue
v) <- forall k a. Map k a -> [(k, a)]
Map.toList Map Word64 TxMetadataValue
m
         , TxMetadataRangeError
err <- TxMetadataValue -> [TxMetadataRangeError]
validateTxMetadataValue TxMetadataValue
v ] of
      []   -> forall a b. b -> Either a b
Right ()
      [(Word64, TxMetadataRangeError)]
errs -> forall a b. a -> Either a b
Left [(Word64, TxMetadataRangeError)]
errs

-- collect all errors in a monoidal fold style
validateTxMetadataValue :: TxMetadataValue -> [TxMetadataRangeError]
validateTxMetadataValue :: TxMetadataValue -> [TxMetadataRangeError]
validateTxMetadataValue (TxMetaNumber Integer
n) =
    [ Integer -> TxMetadataRangeError
TxMetadataNumberOutOfRange Integer
n
    |    Integer
n forall a. Ord a => a -> a -> Bool
>         forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word64)
      Bool -> Bool -> Bool
|| Integer
n forall a. Ord a => a -> a -> Bool
< forall a. Num a => a -> a
negate (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word64))
    ]
validateTxMetadataValue (TxMetaBytes ByteString
bs) =
    [ Int -> TxMetadataRangeError
TxMetadataBytesTooLong Int
len
    | let len :: Int
len = ByteString -> Int
BS.length ByteString
bs
    , Int
len forall a. Ord a => a -> a -> Bool
> Int
txMetadataByteStringMaxLength
    ]
validateTxMetadataValue (TxMetaText Text
txt) =
    [ Int -> TxMetadataRangeError
TxMetadataTextTooLong Int
len
    | let len :: Int
len = ByteString -> Int
BS.length (Text -> ByteString
Text.encodeUtf8 Text
txt)
    , Int
len forall a. Ord a => a -> a -> Bool
> Int
txMetadataTextStringMaxByteLength
    ]
validateTxMetadataValue (TxMetaList [TxMetadataValue]
xs) =
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxMetadataValue -> [TxMetadataRangeError]
validateTxMetadataValue [TxMetadataValue]
xs

validateTxMetadataValue (TxMetaMap [(TxMetadataValue, TxMetadataValue)]
kvs) =
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(TxMetadataValue
k, TxMetadataValue
v) -> TxMetadataValue -> [TxMetadataRangeError]
validateTxMetadataValue TxMetadataValue
k
                     forall a. Semigroup a => a -> a -> a
<> TxMetadataValue -> [TxMetadataRangeError]
validateTxMetadataValue TxMetadataValue
v)
            [(TxMetadataValue, TxMetadataValue)]
kvs

-- | The maximum byte length of a transaction metadata text string value.
txMetadataTextStringMaxByteLength :: Int
txMetadataTextStringMaxByteLength :: Int
txMetadataTextStringMaxByteLength = Int
64

-- | The maximum length of a transaction metadata byte string value.
txMetadataByteStringMaxLength :: Int
txMetadataByteStringMaxLength :: Int
txMetadataByteStringMaxLength = Int
64


-- | An error in transaction metadata due to an out-of-range value.
--
data TxMetadataRangeError =

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

    -- | The length of a text string metadatum value exceeds the maximum of
    -- 64 bytes as UTF8.
    --
  | TxMetadataTextTooLong !Int

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

instance Error TxMetadataRangeError where
  displayError :: TxMetadataRangeError -> String
displayError (TxMetadataNumberOutOfRange Integer
n) =
      String
"Numeric metadata value "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Integer
n
        forall a. Semigroup a => a -> a -> a
<> String
" is outside the range -(2^64-1) .. 2^64-1."
  displayError (TxMetadataTextTooLong Int
actualLen) =
      String
"Text string metadata value must consist of at most "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
txMetadataTextStringMaxByteLength
        forall a. Semigroup a => a -> a -> a
<> String
" UTF8 bytes, but it consists of "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actualLen
        forall a. Semigroup a => a -> a -> a
<> String
" bytes."
  displayError (TxMetadataBytesTooLong Int
actualLen) =
      String
"Byte string metadata value must consist of at most "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
txMetadataByteStringMaxLength
        forall a. Semigroup a => a -> a -> a
<> String
" bytes, but it consists of "
        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
actualLen
        forall a. Semigroup a => a -> a -> a
<> String
" bytes."


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

-- | Tx metadata 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.
--
-- We provide two different mappings between tx metadata and JSON, useful
-- for different purposes:
--
-- 1. A mapping that allows almost any JSON value to be converted into
--    tx metadata. This does not require a specific JSON schema for the
--    input. It does not expose the full representation capability of tx
--    metadata.
--
-- 2. A mapping that exposes the full representation capability of tx
--    metadata, 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 tx metadata 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 tx
-- metadata 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 tx metadata in the form of a JSON schema.
-- This means the full representation is available and can be controlled
-- precisely. It also means any tx metadata can be converted into the JSON and
-- back without loss. That is we can round-trip the tx metadata via the JSON and
-- also round-trip schema-compliant JSON via tx metadata.
--
data TxMetadataJsonSchema =

       -- | Use the \"no schema\" mapping between JSON and tx metadata as
       -- described above.
       TxMetadataJsonNoSchema

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


-- | Convert a value from JSON into tx metadata, using the given choice of
-- mapping between JSON and tx metadata.
--
-- This may fail with a conversion error if the JSON is outside the supported
-- subset for the chosen mapping. See 'TxMetadataJsonSchema' for the details.
--
metadataFromJson :: TxMetadataJsonSchema
                 -> Aeson.Value
                 -> Either TxMetadataJsonError TxMetadata
metadataFromJson :: TxMetadataJsonSchema
-> Value -> Either TxMetadataJsonError TxMetadata
metadataFromJson TxMetadataJsonSchema
schema =
    \Value
vtop -> case Value
vtop of
      -- The top level has to be an object
      -- with unsigned integer (decimal or hex) keys
      Aeson.Object Object
m ->
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Word64 TxMetadataValue -> TxMetadata
TxMetadata forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key
-> Value -> Either TxMetadataJsonError (Word64, TxMetadataValue)
metadataKeyPairFromJson)
        forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
m

      Value
_ -> forall a b. a -> Either a b
Left TxMetadataJsonError
TxMetadataJsonToplevelNotMap
  where
    metadataKeyPairFromJson :: Aeson.Key
                            -> Aeson.Value
                            -> Either TxMetadataJsonError
                                      (Word64, TxMetadataValue)
    metadataKeyPairFromJson :: Key
-> Value -> Either TxMetadataJsonError (Word64, TxMetadataValue)
metadataKeyPairFromJson Key
k Value
v = do
      Word64
k' <- Key -> Either TxMetadataJsonError Word64
convTopLevelKey Key
k
      TxMetadataValue
v' <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Word64 -> Value -> TxMetadataJsonSchemaError -> TxMetadataJsonError
TxMetadataJsonSchemaError Word64
k' Value
v)
                  (Value -> Either TxMetadataJsonSchemaError TxMetadataValue
metadataValueFromJson Value
v)
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Word64 -> Value -> TxMetadataRangeError -> TxMetadataJsonError
TxMetadataRangeError Word64
k' Value
v)
            (TxMetadataValue -> Either TxMetadataRangeError ()
validateMetadataValue TxMetadataValue
v')
      forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
k', TxMetadataValue
v')

    convTopLevelKey :: Aeson.Key -> Either TxMetadataJsonError Word64
    convTopLevelKey :: Key -> Either TxMetadataJsonError Word64
convTopLevelKey (Key -> Text
Aeson.toText -> Text
k) =
      case forall a. Parser a -> Text -> Maybe a
parseAll (Parser ByteString Integer
pUnsigned forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
Atto.endOfInput) Text
k of
        Just Integer
n | Integer
n forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word64)
          -> forall a b. b -> Either a b
Right (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)
        Maybe Integer
_ -> forall a b. a -> Either a b
Left (Text -> TxMetadataJsonError
TxMetadataJsonToplevelBadKey Text
k)

    validateMetadataValue :: TxMetadataValue -> Either TxMetadataRangeError ()
    validateMetadataValue :: TxMetadataValue -> Either TxMetadataRangeError ()
validateMetadataValue TxMetadataValue
v =
      case TxMetadataValue -> [TxMetadataRangeError]
validateTxMetadataValue TxMetadataValue
v of
        []      -> forall a b. b -> Either a b
Right ()
        TxMetadataRangeError
err : [TxMetadataRangeError]
_ -> forall a b. a -> Either a b
Left TxMetadataRangeError
err

    metadataValueFromJson :: Aeson.Value
                          -> Either TxMetadataJsonSchemaError TxMetadataValue
    metadataValueFromJson :: Value -> Either TxMetadataJsonSchemaError TxMetadataValue
metadataValueFromJson =
      case TxMetadataJsonSchema
schema of
        TxMetadataJsonSchema
TxMetadataJsonNoSchema       -> Value -> Either TxMetadataJsonSchemaError TxMetadataValue
metadataValueFromJsonNoSchema
        TxMetadataJsonSchema
TxMetadataJsonDetailedSchema -> Value -> Either TxMetadataJsonSchemaError TxMetadataValue
metadataValueFromJsonDetailedSchema


-- | Convert a tx metadata value into JSON , using the given choice of mapping
-- between JSON and tx metadata.
--
-- This conversion is total but is not necessarily invertible.
-- See 'TxMetadataJsonSchema' for the details.
--
metadataToJson :: TxMetadataJsonSchema
               -> TxMetadata
               -> Aeson.Value
metadataToJson :: TxMetadataJsonSchema -> TxMetadata -> Value
metadataToJson TxMetadataJsonSchema
schema =
    \(TxMetadata Map Word64 TxMetadataValue
mdMap) ->
    [(Key, Value)] -> Value
Aeson.object
      [ (String -> Key
Aeson.fromString (forall a. Show a => a -> String
show Word64
k), TxMetadataValue -> Value
metadataValueToJson TxMetadataValue
v)
      | (Word64
k, TxMetadataValue
v) <- forall k a. Map k a -> [(k, a)]
Map.toList Map Word64 TxMetadataValue
mdMap ]
  where
    metadataValueToJson :: TxMetadataValue -> Aeson.Value
    metadataValueToJson :: TxMetadataValue -> Value
metadataValueToJson =
      case TxMetadataJsonSchema
schema of
        TxMetadataJsonSchema
TxMetadataJsonNoSchema       -> TxMetadataValue -> Value
metadataValueToJsonNoSchema
        TxMetadataJsonSchema
TxMetadataJsonDetailedSchema -> TxMetadataValue -> Value
metadataValueToJsonDetailedSchema


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

metadataValueToJsonNoSchema :: TxMetadataValue -> Aeson.Value
metadataValueToJsonNoSchema :: TxMetadataValue -> Value
metadataValueToJsonNoSchema = TxMetadataValue -> Value
conv
  where
    conv :: TxMetadataValue -> Aeson.Value
    conv :: TxMetadataValue -> Value
conv (TxMetaNumber Integer
n) = Scientific -> Value
Aeson.Number (forall a. Num a => Integer -> a
fromInteger Integer
n)
    conv (TxMetaBytes ByteString
bs) = Text -> Value
Aeson.String (Text
bytesPrefix
                                       forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
Text.decodeLatin1 (ByteString -> ByteString
Base16.encode ByteString
bs))

    conv (TxMetaText Text
txt) = Text -> Value
Aeson.String Text
txt
    conv (TxMetaList  [TxMetadataValue]
vs) = Array -> Value
Aeson.Array (forall a. [a] -> Vector a
Vector.fromList (forall a b. (a -> b) -> [a] -> [b]
map TxMetadataValue -> Value
conv [TxMetadataValue]
vs))
    conv (TxMetaMap  [(TxMetadataValue, TxMetadataValue)]
kvs) = [(Key, Value)] -> Value
Aeson.object
                              [ (TxMetadataValue -> Key
convKey TxMetadataValue
k, TxMetadataValue -> Value
conv TxMetadataValue
v)
                              | (TxMetadataValue
k, TxMetadataValue
v) <- [(TxMetadataValue, TxMetadataValue)]
kvs ]

    -- Metadata 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 :: TxMetadataValue -> Aeson.Key
    convKey :: TxMetadataValue -> Key
convKey (TxMetaNumber Integer
n) = String -> Key
Aeson.fromString (forall a. Show a => a -> String
show Integer
n)
    convKey (TxMetaBytes ByteString
bs) = Text -> Key
Aeson.fromText forall a b. (a -> b) -> a -> b
$ Text
bytesPrefix
                            forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
Text.decodeLatin1 (ByteString -> ByteString
Base16.encode ByteString
bs)
    convKey (TxMetaText Text
txt) = Text -> Key
Aeson.fromText Text
txt
    convKey TxMetadataValue
v                = Text -> Key
Aeson.fromText
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.Lazy.toStrict
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Text
Aeson.Text.encodeToLazyText
                             forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxMetadataValue -> Value
conv
                             forall a b. (a -> b) -> a -> b
$ TxMetadataValue
v

metadataValueFromJsonNoSchema :: Aeson.Value
                              -> Either TxMetadataJsonSchemaError
                                        TxMetadataValue
metadataValueFromJsonNoSchema :: Value -> Either TxMetadataJsonSchemaError TxMetadataValue
metadataValueFromJsonNoSchema = Value -> Either TxMetadataJsonSchemaError TxMetadataValue
conv
  where
    conv :: Aeson.Value
         -> Either TxMetadataJsonSchemaError TxMetadataValue
    conv :: Value -> Either TxMetadataJsonSchemaError TxMetadataValue
conv Value
Aeson.Null   = forall a b. a -> Either a b
Left TxMetadataJsonSchemaError
TxMetadataJsonNullNotAllowed
    conv Aeson.Bool{} = forall a b. a -> Either a b
Left TxMetadataJsonSchemaError
TxMetadataJsonBoolNotAllowed

    conv (Aeson.Number Scientific
d) =
      case forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
d :: Either Double Integer of
        Left  Double
n -> forall a b. a -> Either a b
Left (Double -> TxMetadataJsonSchemaError
TxMetadataJsonNumberNotInteger Double
n)
        Right Integer
n -> forall a b. b -> Either a b
Right (Integer -> TxMetadataValue
TxMetaNumber 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 forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'F') ByteString
bs')
      = forall a b. b -> Either a b
Right (ByteString -> TxMetadataValue
TxMetaBytes ByteString
bs)

    conv (Aeson.String Text
s) = forall a b. b -> Either a b
Right (Text -> TxMetadataValue
TxMetaText Text
s)

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

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

    convKey :: Text -> TxMetadataValue
    convKey :: Text -> TxMetadataValue
convKey Text
s =
      forall a. a -> Maybe a -> a
fromMaybe (Text -> TxMetadataValue
TxMetaText Text
s) forall a b. (a -> b) -> a -> b
$
      forall a. Parser a -> Text -> Maybe a
parseAll ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> TxMetadataValue
TxMetaNumber Parser ByteString Integer
pSigned forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
Atto.endOfInput)
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> TxMetadataValue
TxMetaBytes  Parser ByteString
pBytes  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* 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
--

metadataValueToJsonDetailedSchema :: TxMetadataValue -> Aeson.Value
metadataValueToJsonDetailedSchema :: TxMetadataValue -> Value
metadataValueToJsonDetailedSchema  = TxMetadataValue -> Value
conv
  where
    conv :: TxMetadataValue -> Aeson.Value
    conv :: TxMetadataValue -> Value
conv (TxMetaNumber Integer
n) = Key -> Value -> Value
singleFieldObject Key
"int"
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Value
Aeson.Number
                          forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger Integer
n
    conv (TxMetaBytes ByteString
bs) = Key -> Value -> Value
singleFieldObject Key
"bytes"
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
Aeson.String
                          forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeLatin1 (ByteString -> ByteString
Base16.encode ByteString
bs)
    conv (TxMetaText Text
txt) = Key -> Value -> Value
singleFieldObject Key
"string"
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
Aeson.String
                          forall a b. (a -> b) -> a -> b
$ Text
txt
    conv (TxMetaList  [TxMetadataValue]
vs) = Key -> Value -> Value
singleFieldObject Key
"list"
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Value
Aeson.Array
                          forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
Vector.fromList (forall a b. (a -> b) -> [a] -> [b]
map TxMetadataValue -> Value
conv [TxMetadataValue]
vs)
    conv (TxMetaMap  [(TxMetadataValue, TxMetadataValue)]
kvs) = Key -> Value -> Value
singleFieldObject Key
"map"
                          forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Value
Aeson.Array
                          forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
Vector.fromList
                              [ [(Key, Value)] -> Value
Aeson.object [ (Key
"k", TxMetadataValue -> Value
conv TxMetadataValue
k), (Key
"v", TxMetadataValue -> Value
conv TxMetadataValue
v) ]
                              | (TxMetadataValue
k, TxMetadataValue
v) <- [(TxMetadataValue, TxMetadataValue)]
kvs ]

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

metadataValueFromJsonDetailedSchema :: Aeson.Value
                                    -> Either TxMetadataJsonSchemaError
                                              TxMetadataValue
metadataValueFromJsonDetailedSchema :: Value -> Either TxMetadataJsonSchemaError TxMetadataValue
metadataValueFromJsonDetailedSchema = Value -> Either TxMetadataJsonSchemaError TxMetadataValue
conv
  where
    conv :: Aeson.Value
         -> Either TxMetadataJsonSchemaError TxMetadataValue
    conv :: Value -> Either TxMetadataJsonSchemaError TxMetadataValue
conv (Aeson.Object Object
m) =
      case forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
m of
        [(Key
"int", Aeson.Number Scientific
d)] ->
          case forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger Scientific
d :: Either Double Integer of
            Left  Double
n -> forall a b. a -> Either a b
Left (Double -> TxMetadataJsonSchemaError
TxMetadataJsonNumberNotInteger Double
n)
            Right Integer
n -> forall a b. b -> Either a b
Right (Integer -> TxMetadataValue
TxMetaNumber Integer
n)

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

        [(Key
"string", Aeson.String Text
s)] -> forall a b. b -> Either a b
Right (Text -> TxMetadataValue
TxMetaText Text
s)

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

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

        [(Key
key, Value
v)] | Key
key forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Key
"int", Key
"bytes", Key
"string", Key
"list", Key
"map"] ->
            forall a b. a -> Either a b
Left (Text -> Value -> TxMetadataJsonSchemaError
TxMetadataJsonTypeMismatch (Key -> Text
Aeson.toText Key
key) Value
v)

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

    conv Value
v = forall a b. a -> Either a b
Left (Value -> TxMetadataJsonSchemaError
TxMetadataJsonNotObject Value
v)

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

    convKeyValuePair Value
v = forall a b. a -> Either a b
Left (Value -> TxMetadataJsonSchemaError
TxMetadataJsonBadMapPair Value
v)


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

data TxMetadataJsonError =
       TxMetadataJsonToplevelNotMap
     | TxMetadataJsonToplevelBadKey !Text
     | TxMetadataJsonSchemaError !Word64 !Aeson.Value !TxMetadataJsonSchemaError
     | TxMetadataRangeError      !Word64 !Aeson.Value !TxMetadataRangeError
  deriving (TxMetadataJsonError -> TxMetadataJsonError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxMetadataJsonError -> TxMetadataJsonError -> Bool
$c/= :: TxMetadataJsonError -> TxMetadataJsonError -> Bool
== :: TxMetadataJsonError -> TxMetadataJsonError -> Bool
$c== :: TxMetadataJsonError -> TxMetadataJsonError -> Bool
Eq, Int -> TxMetadataJsonError -> ShowS
[TxMetadataJsonError] -> ShowS
TxMetadataJsonError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxMetadataJsonError] -> ShowS
$cshowList :: [TxMetadataJsonError] -> ShowS
show :: TxMetadataJsonError -> String
$cshow :: TxMetadataJsonError -> String
showsPrec :: Int -> TxMetadataJsonError -> ShowS
$cshowsPrec :: Int -> TxMetadataJsonError -> ShowS
Show)

data TxMetadataJsonSchemaError =
       -- Only used for 'TxMetadataJsonNoSchema'
       TxMetadataJsonNullNotAllowed
     | TxMetadataJsonBoolNotAllowed

       -- Used by both mappings
     | TxMetadataJsonNumberNotInteger !Double

       -- Only used for 'TxMetadataJsonDetailedSchema'
     | TxMetadataJsonNotObject !Aeson.Value
     | TxMetadataJsonBadObject ![(Text, Aeson.Value)]
     | TxMetadataJsonBadMapPair !Aeson.Value
     | TxMetadataJsonTypeMismatch !Text !Aeson.Value
  deriving (TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError -> Bool
$c/= :: TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError -> Bool
== :: TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError -> Bool
$c== :: TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError -> Bool
Eq, Int -> TxMetadataJsonSchemaError -> ShowS
[TxMetadataJsonSchemaError] -> ShowS
TxMetadataJsonSchemaError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxMetadataJsonSchemaError] -> ShowS
$cshowList :: [TxMetadataJsonSchemaError] -> ShowS
show :: TxMetadataJsonSchemaError -> String
$cshow :: TxMetadataJsonSchemaError -> String
showsPrec :: Int -> TxMetadataJsonSchemaError -> ShowS
$cshowsPrec :: Int -> TxMetadataJsonSchemaError -> ShowS
Show)

instance Error TxMetadataJsonError where
    displayError :: TxMetadataJsonError -> String
displayError TxMetadataJsonError
TxMetadataJsonToplevelNotMap =
        String
"The JSON metadata top level must be a map (JSON object) from word to "
     forall a. [a] -> [a] -> [a]
++ String
"value."
    displayError (TxMetadataJsonToplevelBadKey Text
k) =
        String
"The JSON metadata top level must be a map (JSON object) with unsigned "
     forall a. [a] -> [a] -> [a]
++ String
"integer keys.\nInvalid key: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
k
    displayError (TxMetadataJsonSchemaError Word64
k Value
v TxMetadataJsonSchemaError
detail) =
        String
"JSON schema error within the metadata item " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word64
k forall a. [a] -> [a] -> [a]
++ String
": "
     forall a. [a] -> [a] -> [a]
++ ByteString -> String
LBS.unpack (forall a. ToJSON a => a -> ByteString
Aeson.encode Value
v) forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall e. Error e => e -> String
displayError TxMetadataJsonSchemaError
detail
    displayError (TxMetadataRangeError Word64
k Value
v TxMetadataRangeError
detail) =
        String
"Value out of range within the metadata item " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word64
k forall a. [a] -> [a] -> [a]
++ String
": "
     forall a. [a] -> [a] -> [a]
++ ByteString -> String
LBS.unpack (forall a. ToJSON a => a -> ByteString
Aeson.encode Value
v) forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall e. Error e => e -> String
displayError TxMetadataRangeError
detail

instance Error TxMetadataJsonSchemaError where
    displayError :: TxMetadataJsonSchemaError -> String
displayError TxMetadataJsonSchemaError
TxMetadataJsonNullNotAllowed =
        String
"JSON null values are not supported."
    displayError TxMetadataJsonSchemaError
TxMetadataJsonBoolNotAllowed =
        String
"JSON bool values are not supported."
    displayError (TxMetadataJsonNumberNotInteger Double
d) =
        String
"JSON numbers must be integers. Unexpected value: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Double
d
    displayError (TxMetadataJsonNotObject Value
v) =
        String
"JSON object expected. Unexpected value: "
     forall a. [a] -> [a] -> [a]
++ ByteString -> String
LBS.unpack (forall a. ToJSON a => a -> ByteString
Aeson.encode Value
v)
    displayError (TxMetadataJsonBadObject [(Text, Value)]
v) =
        String
"JSON object does not match the schema.\nExpected a single field named "
     forall a. [a] -> [a] -> [a]
++ String
"\"int\", \"bytes\", \"string\", \"list\" or \"map\".\n"
     forall a. [a] -> [a] -> [a]
++ String
"Unexpected object field(s): "
     forall a. [a] -> [a] -> [a]
++ ByteString -> String
LBS.unpack (forall a. ToJSON a => a -> ByteString
Aeson.encode ([(Key, Value)] -> Value
Aeson.object forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Key
Aeson.fromText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Value)]
v))
    displayError (TxMetadataJsonBadMapPair Value
v) =
        String
"Expected a list of key/value pair { \"k\": ..., \"v\": ... } objects."
     forall a. [a] -> [a] -> [a]
++ String
"\nUnexpected value: " forall a. [a] -> [a] -> [a]
++ ByteString -> String
LBS.unpack (forall a. ToJSON a => a -> ByteString
Aeson.encode Value
v)
    displayError (TxMetadataJsonTypeMismatch Text
k Value
v) =
        String
"The value in the field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
k forall a. [a] -> [a] -> [a]
++ String
" does not have the type "
     forall a. [a] -> [a] -> [a]
++ String
"required by the schema.\nUnexpected value: "
     forall a. [a] -> [a] -> [a]
++ ByteString -> String
LBS.unpack (forall a. ToJSON a => a -> ByteString
Aeson.encode Value
v)


-- ----------------------------------------------------------------------------
-- Shared parsing utils
--

parseAll :: Atto.Parser a -> Text -> Maybe a
parseAll :: forall a. Parser a -> Text -> Maybe a
parseAll Parser a
p = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just
           forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> ByteString -> Either String a
Atto.parseOnly Parser a
p
           forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8

pUnsigned :: Atto.Parser Integer
pUnsigned :: Parser ByteString Integer
pUnsigned = do
    ByteString
bs <- (Char -> Bool) -> Parser ByteString
Atto.takeWhile1 Char -> Bool
Atto.isDigit
    -- no redundant leading 0s allowed, or we cannot round-trip properly
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (ByteString -> Int
BS.length ByteString
bs forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& ByteString -> Char
BSC.head ByteString
bs forall a. Eq a => a -> a -> Bool
== Char
'0'))
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' forall {a} {a}. (Integral a, Num a) => a -> a -> a
step Integer
0 ByteString
bs
  where
    step :: a -> a -> a
step a
a a
w = a
a forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
w forall a. Num a => a -> a -> a
- a
48)

pSigned :: Atto.Parser Integer
pSigned :: Parser ByteString Integer
pSigned = forall a. Num a => Parser a -> Parser a
Atto.signed Parser ByteString Integer
pUnsigned

pBytes :: Atto.Parser ByteString
pBytes :: Parser ByteString
pBytes = do
  ByteString
_ <- ByteString -> Parser ByteString
Atto.string ByteString
"0x"
  ByteString
remaining <- Parser ByteString
Atto.takeByteString
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Bool) -> ByteString -> Bool
BSC.any Char -> Bool
hexUpper ByteString
remaining) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unexpected uppercase hex characters in " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
remaining)
  case ByteString -> Either String ByteString
Base16.decode ByteString
remaining of
    Right ByteString
bs -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
    Either String ByteString
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Expecting base16 encoded string, found: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
remaining)
  where
    hexUpper :: Char -> Bool
hexUpper Char
c = Char
c forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'F'