{-# 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           Prelude

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
(TxMetadata -> TxMetadata -> Bool)
-> (TxMetadata -> TxMetadata -> Bool) -> Eq TxMetadata
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
(Int -> TxMetadata -> ShowS)
-> (TxMetadata -> String)
-> ([TxMetadata] -> ShowS)
-> Show TxMetadata
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
(TxMetadataValue -> TxMetadataValue -> Bool)
-> (TxMetadataValue -> TxMetadataValue -> Bool)
-> Eq TxMetadataValue
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
Eq TxMetadataValue
-> (TxMetadataValue -> TxMetadataValue -> Ordering)
-> (TxMetadataValue -> TxMetadataValue -> Bool)
-> (TxMetadataValue -> TxMetadataValue -> Bool)
-> (TxMetadataValue -> TxMetadataValue -> Bool)
-> (TxMetadataValue -> TxMetadataValue -> Bool)
-> (TxMetadataValue -> TxMetadataValue -> TxMetadataValue)
-> (TxMetadataValue -> TxMetadataValue -> TxMetadataValue)
-> Ord 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
$cp1Ord :: Eq TxMetadataValue
Ord, Int -> TxMetadataValue -> ShowS
[TxMetadataValue] -> ShowS
TxMetadataValue -> String
(Int -> TxMetadataValue -> ShowS)
-> (TxMetadataValue -> String)
-> ([TxMetadataValue] -> ShowS)
-> Show TxMetadataValue
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 Map Word64 TxMetadataValue
-> Map Word64 TxMetadataValue -> Map Word64 TxMetadataValue
forall a. Semigroup a => a -> a -> a
<> Map Word64 TxMetadataValue
m2)

instance Monoid TxMetadata where
    mempty :: TxMetadata
mempty = Map Word64 TxMetadataValue -> TxMetadata
TxMetadata Map Word64 TxMetadataValue
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 =
          Metadata () -> ByteString
forall a. ToCBOR a => a -> ByteString
CBOR.serialize'
        (Metadata () -> ByteString)
-> (TxMetadata -> Metadata ()) -> TxMetadata -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Word64 Metadatum -> Metadata ()
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.
        (Map Word64 Metadatum -> Metadata ())
-> (TxMetadata -> Map Word64 Metadatum)
-> TxMetadata
-> Metadata ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Word64 TxMetadataValue -> Map Word64 Metadatum
toShelleyMetadata
        (Map Word64 TxMetadataValue -> Map Word64 Metadatum)
-> (TxMetadata -> Map Word64 TxMetadataValue)
-> TxMetadata
-> Map Word64 Metadatum
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
AsTxMetadata ByteString
bs =
          Map Word64 TxMetadataValue -> TxMetadata
TxMetadata
        (Map Word64 TxMetadataValue -> TxMetadata)
-> (Metadata () -> Map Word64 TxMetadataValue)
-> Metadata ()
-> TxMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Word64 Metadatum -> Map Word64 TxMetadataValue
fromShelleyMetadata
        (Map Word64 Metadatum -> Map Word64 TxMetadataValue)
-> (Metadata () -> Map Word64 Metadatum)
-> Metadata ()
-> Map Word64 TxMetadataValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Shelley.Metadata Map Word64 Metadatum
m) -> Map Word64 Metadatum
m)
      (Metadata () -> TxMetadata)
-> Either DecoderError (Metadata ())
-> Either DecoderError TxMetadata
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text
-> (forall s. Decoder s (Annotator (Metadata ())))
-> LByteString
-> Either DecoderError (Metadata ())
forall a.
Text
-> (forall s. Decoder s (Annotator a))
-> LByteString
-> Either DecoderError a
CBOR.decodeAnnotator Text
"TxMetadata" forall s. Decoder s (Annotator (Metadata ()))
forall a s. FromCBOR a => Decoder s a
fromCBOR (ByteString -> LByteString
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 = (TxMetadataValue -> Metadatum)
-> Map Word64 TxMetadataValue -> Map Word64 Metadatum
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 = (Metadatum -> TxMetadataValue)
-> Map Word64 Metadatum -> Map Word64 TxMetadataValue
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) <- Map Word64 TxMetadataValue -> [(Word64, TxMetadataValue)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Word64 TxMetadataValue
m
         , TxMetadataRangeError
err <- TxMetadataValue -> [TxMetadataRangeError]
validateTxMetadataValue TxMetadataValue
v ] of
      []   -> () -> Either [(Word64, TxMetadataRangeError)] ()
forall a b. b -> Either a b
Right ()
      [(Word64, TxMetadataRangeError)]
errs -> [(Word64, TxMetadataRangeError)]
-> Either [(Word64, TxMetadataRangeError)] ()
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 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))
    ]
validateTxMetadataValue (TxMetaBytes ByteString
bs) =
    [ Int -> TxMetadataRangeError
TxMetadataBytesTooLong 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
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
txMetadataTextStringMaxByteLength
    ]
validateTxMetadataValue (TxMetaList [TxMetadataValue]
xs) =
    (TxMetadataValue -> [TxMetadataRangeError])
-> [TxMetadataValue] -> [TxMetadataRangeError]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxMetadataValue -> [TxMetadataRangeError]
validateTxMetadataValue [TxMetadataValue]
xs

validateTxMetadataValue (TxMetaMap [(TxMetadataValue, TxMetadataValue)]
kvs) =
    ((TxMetadataValue, TxMetadataValue) -> [TxMetadataRangeError])
-> [(TxMetadataValue, TxMetadataValue)] -> [TxMetadataRangeError]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(TxMetadataValue
k, TxMetadataValue
v) -> TxMetadataValue -> [TxMetadataRangeError]
validateTxMetadataValue TxMetadataValue
k
                     [TxMetadataRangeError]
-> [TxMetadataRangeError] -> [TxMetadataRangeError]
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
(TxMetadataRangeError -> TxMetadataRangeError -> Bool)
-> (TxMetadataRangeError -> TxMetadataRangeError -> Bool)
-> Eq TxMetadataRangeError
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
(Int -> TxMetadataRangeError -> ShowS)
-> (TxMetadataRangeError -> String)
-> ([TxMetadataRangeError] -> ShowS)
-> Show TxMetadataRangeError
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 "
        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 (TxMetadataTextTooLong Int
actualLen) =
      String
"Text string metadata value must consist of at most "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
txMetadataTextStringMaxByteLength
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" UTF8 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."
  displayError (TxMetadataBytesTooLong Int
actualLen) =
      String
"Byte string metadata value must consist of at most "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
txMetadataByteStringMaxLength
        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
--

-- | 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
(TxMetadataJsonSchema -> TxMetadataJsonSchema -> Bool)
-> (TxMetadataJsonSchema -> TxMetadataJsonSchema -> Bool)
-> Eq TxMetadataJsonSchema
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
(Int -> TxMetadataJsonSchema -> ShowS)
-> (TxMetadataJsonSchema -> String)
-> ([TxMetadataJsonSchema] -> ShowS)
-> Show TxMetadataJsonSchema
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 ->
          ([(Word64, TxMetadataValue)] -> TxMetadata)
-> Either TxMetadataJsonError [(Word64, TxMetadataValue)]
-> Either TxMetadataJsonError TxMetadata
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Word64 TxMetadataValue -> TxMetadata
TxMetadata (Map Word64 TxMetadataValue -> TxMetadata)
-> ([(Word64, TxMetadataValue)] -> Map Word64 TxMetadataValue)
-> [(Word64, TxMetadataValue)]
-> TxMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Word64, TxMetadataValue)] -> Map Word64 TxMetadataValue
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList)
        (Either TxMetadataJsonError [(Word64, TxMetadataValue)]
 -> Either TxMetadataJsonError TxMetadata)
-> ([(Key, Value)]
    -> Either TxMetadataJsonError [(Word64, TxMetadataValue)])
-> [(Key, Value)]
-> Either TxMetadataJsonError TxMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Value)
 -> Either TxMetadataJsonError (Word64, TxMetadataValue))
-> [(Key, Value)]
-> Either TxMetadataJsonError [(Word64, TxMetadataValue)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Key
 -> Value -> Either TxMetadataJsonError (Word64, TxMetadataValue))
-> (Key, Value)
-> Either TxMetadataJsonError (Word64, TxMetadataValue)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key
-> Value -> Either TxMetadataJsonError (Word64, TxMetadataValue)
metadataKeyPairFromJson)
        ([(Key, Value)] -> Either TxMetadataJsonError TxMetadata)
-> [(Key, Value)] -> Either TxMetadataJsonError TxMetadata
forall a b. (a -> b) -> a -> b
$ Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
m

      Value
_ -> TxMetadataJsonError -> Either TxMetadataJsonError TxMetadata
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' <- (TxMetadataJsonSchemaError -> TxMetadataJsonError)
-> Either TxMetadataJsonSchemaError TxMetadataValue
-> Either TxMetadataJsonError TxMetadataValue
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)
      (TxMetadataRangeError -> TxMetadataJsonError)
-> Either TxMetadataRangeError () -> Either TxMetadataJsonError ()
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')
      (Word64, TxMetadataValue)
-> Either TxMetadataJsonError (Word64, TxMetadataValue)
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 Parser Integer -> Text -> Maybe Integer
forall a. Parser a -> Text -> Maybe a
parseAll (Parser Integer
pUnsigned Parser Integer -> Parser ByteString () -> Parser Integer
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
Atto.endOfInput) Text
k of
        Just 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)
          -> Word64 -> Either TxMetadataJsonError Word64
forall a b. b -> Either a b
Right (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)
        Maybe Integer
_ -> TxMetadataJsonError -> Either TxMetadataJsonError Word64
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
        []      -> () -> Either TxMetadataRangeError ()
forall a b. b -> Either a b
Right ()
        TxMetadataRangeError
err : [TxMetadataRangeError]
_ -> TxMetadataRangeError -> Either 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 (Word64 -> String
forall a. Show a => a -> String
show Word64
k), TxMetadataValue -> Value
metadataValueToJson TxMetadataValue
v)
      | (Word64
k, TxMetadataValue
v) <- Map Word64 TxMetadataValue -> [(Word64, TxMetadataValue)]
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 (Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
n)
    conv (TxMetaBytes ByteString
bs) = 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 (TxMetaText Text
txt) = Text -> Value
Aeson.String Text
txt
    conv (TxMetaList  [TxMetadataValue]
vs) = Array -> Value
Aeson.Array ([Value] -> Array
forall a. [a] -> Vector a
Vector.fromList ((TxMetadataValue -> Value) -> [TxMetadataValue] -> [Value]
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 (Integer -> String
forall a. Show a => a -> String
show Integer
n)
    convKey (TxMetaBytes 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 (TxMetaText Text
txt) = Text -> Key
Aeson.fromText Text
txt
    convKey TxMetadataValue
v                = Text -> Key
Aeson.fromText
                             (Text -> Key)
-> (TxMetadataValue -> Text) -> TxMetadataValue -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.Lazy.toStrict
                             (Text -> Text)
-> (TxMetadataValue -> Text) -> TxMetadataValue -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Text
forall a. ToJSON a => a -> Text
Aeson.Text.encodeToLazyText
                             (Value -> Text)
-> (TxMetadataValue -> Value) -> TxMetadataValue -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxMetadataValue -> Value
conv
                             (TxMetadataValue -> Key) -> TxMetadataValue -> Key
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   = TxMetadataJsonSchemaError
-> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b. a -> Either a b
Left TxMetadataJsonSchemaError
TxMetadataJsonNullNotAllowed
    conv Aeson.Bool{} = TxMetadataJsonSchemaError
-> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b. a -> Either a b
Left TxMetadataJsonSchemaError
TxMetadataJsonBoolNotAllowed

    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 -> TxMetadataJsonSchemaError
-> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b. a -> Either a b
Left (Double -> TxMetadataJsonSchemaError
TxMetadataJsonNumberNotInteger Double
n)
        Right Integer
n -> TxMetadataValue -> Either TxMetadataJsonSchemaError TxMetadataValue
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 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')
      = TxMetadataValue -> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b. b -> Either a b
Right (ByteString -> TxMetadataValue
TxMetaBytes ByteString
bs)

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

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

    conv (Aeson.Object Object
kvs) =
        ([(TxMetadataValue, TxMetadataValue)] -> TxMetadataValue)
-> Either
     TxMetadataJsonSchemaError [(TxMetadataValue, TxMetadataValue)]
-> Either TxMetadataJsonSchemaError TxMetadataValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(TxMetadataValue, TxMetadataValue)] -> TxMetadataValue
TxMetaMap
      (Either
   TxMetadataJsonSchemaError [(TxMetadataValue, TxMetadataValue)]
 -> Either TxMetadataJsonSchemaError TxMetadataValue)
-> ([(Key, Value)]
    -> Either
         TxMetadataJsonSchemaError [(TxMetadataValue, TxMetadataValue)])
-> [(Key, Value)]
-> Either TxMetadataJsonSchemaError TxMetadataValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Value)
 -> Either
      TxMetadataJsonSchemaError (TxMetadataValue, TxMetadataValue))
-> [(Text, Value)]
-> Either
     TxMetadataJsonSchemaError [(TxMetadataValue, TxMetadataValue)]
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) (TxMetadataValue -> (TxMetadataValue, TxMetadataValue))
-> Either TxMetadataJsonSchemaError TxMetadataValue
-> Either
     TxMetadataJsonSchemaError (TxMetadataValue, TxMetadataValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either TxMetadataJsonSchemaError TxMetadataValue
conv Value
v)
      ([(Text, Value)]
 -> Either
      TxMetadataJsonSchemaError [(TxMetadataValue, TxMetadataValue)])
-> ([(Key, Value)] -> [(Text, Value)])
-> [(Key, Value)]
-> Either
     TxMetadataJsonSchemaError [(TxMetadataValue, TxMetadataValue)]
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)])
-> ([(Key, Value)] -> [(Text, Value)])
-> [(Key, Value)]
-> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Value) -> (Text, Value))
-> [(Key, Value)] -> [(Text, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key -> Text) -> (Key, Value) -> (Text, Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Key -> Text
Aeson.toText)
      ([(Key, Value)]
 -> Either TxMetadataJsonSchemaError TxMetadataValue)
-> [(Key, Value)]
-> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b. (a -> b) -> a -> b
$ Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
kvs

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

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"
                          (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 (TxMetaBytes 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 (TxMetaText Text
txt) = Key -> Value -> Value
singleFieldObject Key
"string"
                          (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
$ Text
txt
    conv (TxMetaList  [TxMetadataValue]
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 ((TxMetadataValue -> Value) -> [TxMetadataValue] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map TxMetadataValue -> Value
conv [TxMetadataValue]
vs)
    conv (TxMetaMap  [(TxMetadataValue, TxMetadataValue)]
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
                              [ [(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 Object -> [(Key, Value)]
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 -> TxMetadataJsonSchemaError
-> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b. a -> Either a b
Left (Double -> TxMetadataJsonSchemaError
TxMetadataJsonNumberNotInteger Double
n)
            Right Integer
n -> TxMetadataValue -> Either TxMetadataJsonSchemaError TxMetadataValue
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)
          -> TxMetadataValue -> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b. b -> Either a b
Right (ByteString -> TxMetadataValue
TxMetaBytes ByteString
bs)

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

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

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

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

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

    conv Value
v = TxMetadataJsonSchemaError
-> Either TxMetadataJsonSchemaError TxMetadataValue
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)
      | 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
      = (,) (TxMetadataValue
 -> TxMetadataValue -> (TxMetadataValue, TxMetadataValue))
-> Either TxMetadataJsonSchemaError TxMetadataValue
-> Either
     TxMetadataJsonSchemaError
     (TxMetadataValue -> (TxMetadataValue, TxMetadataValue))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Either TxMetadataJsonSchemaError TxMetadataValue
conv Value
k Either
  TxMetadataJsonSchemaError
  (TxMetadataValue -> (TxMetadataValue, TxMetadataValue))
-> Either TxMetadataJsonSchemaError TxMetadataValue
-> Either
     TxMetadataJsonSchemaError (TxMetadataValue, TxMetadataValue)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Either TxMetadataJsonSchemaError TxMetadataValue
conv Value
v

    convKeyValuePair Value
v = TxMetadataJsonSchemaError
-> Either
     TxMetadataJsonSchemaError (TxMetadataValue, TxMetadataValue)
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
(TxMetadataJsonError -> TxMetadataJsonError -> Bool)
-> (TxMetadataJsonError -> TxMetadataJsonError -> Bool)
-> Eq TxMetadataJsonError
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
(Int -> TxMetadataJsonError -> ShowS)
-> (TxMetadataJsonError -> String)
-> ([TxMetadataJsonError] -> ShowS)
-> Show TxMetadataJsonError
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
(TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError -> Bool)
-> (TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError -> Bool)
-> Eq TxMetadataJsonSchemaError
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
(Int -> TxMetadataJsonSchemaError -> ShowS)
-> (TxMetadataJsonSchemaError -> String)
-> ([TxMetadataJsonSchemaError] -> ShowS)
-> Show TxMetadataJsonSchemaError
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 "
     String -> ShowS
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 "
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"integer keys.\nInvalid key: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": "
     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]
++ TxMetadataJsonSchemaError -> String
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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": "
     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]
++ TxMetadataRangeError -> String
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: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Double -> String
forall a. Show a => a -> String
show Double
d
    displayError (TxMetadataJsonNotObject 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 (TxMetadataJsonBadObject [(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 (Value -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode ([(Key, Value)] -> Value
Aeson.object ([(Key, Value)] -> Value) -> [(Key, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ (Text -> Key) -> (Text, Value) -> (Key, Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Key
Aeson.fromText ((Text, Value) -> (Key, Value))
-> [(Text, Value)] -> [(Key, Value)]
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."
     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 (TxMetadataJsonTypeMismatch 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)


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

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

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

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

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