{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

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

    -- * Class
  , AsTxMetadata (..)

    -- * Constructing metadata
  , TxMetadataValue (..)
  , makeTransactionMetadata
  , mergeTransactionMetadata
  , metaTextChunks
  , metaBytesChunks

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

    -- * Conversion to\/from JSON
  , TxMetadataJsonSchema (..)
  , metadataFromJson
  , metadataToJson
  , metadataValueFromJsonNoSchema
  , 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.Pretty
import           Cardano.Api.SerialiseCBOR (SerialiseAsCBOR (..))

import qualified Cardano.Ledger.Binary as CBOR
import qualified Cardano.Ledger.Shelley.TxAuxData as Shelley

import qualified Codec.CBOR.Magic as CBOR
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 (bimap, 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           Data.Data (Data)
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.Text.Lazy.Builder as Text.Builder
import           Data.Word
import           GHC.Exts (IsList (..))

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

newtype TxMetadata = TxMetadata {TxMetadata -> Map Word64 TxMetadataValue
unTxMetadata :: 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
$c== :: TxMetadata -> TxMetadata -> Bool
== :: TxMetadata -> TxMetadata -> Bool
$c/= :: TxMetadata -> TxMetadata -> Bool
/= :: 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
$cshowsPrec :: Int -> TxMetadata -> ShowS
showsPrec :: Int -> TxMetadata -> ShowS
$cshow :: TxMetadata -> String
show :: TxMetadata -> String
$cshowList :: [TxMetadata] -> ShowS
showList :: [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
$c== :: TxMetadataValue -> TxMetadataValue -> Bool
== :: TxMetadataValue -> TxMetadataValue -> Bool
$c/= :: TxMetadataValue -> TxMetadataValue -> Bool
/= :: 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
$ccompare :: TxMetadataValue -> TxMetadataValue -> Ordering
compare :: TxMetadataValue -> TxMetadataValue -> Ordering
$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
>= :: TxMetadataValue -> TxMetadataValue -> Bool
$cmax :: TxMetadataValue -> TxMetadataValue -> TxMetadataValue
max :: TxMetadataValue -> TxMetadataValue -> TxMetadataValue
$cmin :: TxMetadataValue -> TxMetadataValue -> TxMetadataValue
min :: TxMetadataValue -> TxMetadataValue -> 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
$cshowsPrec :: Int -> TxMetadataValue -> ShowS
showsPrec :: Int -> TxMetadataValue -> ShowS
$cshow :: TxMetadataValue -> String
show :: TxMetadataValue -> String
$cshowList :: [TxMetadataValue] -> ShowS
showList :: [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 =
    -- This is a workaround. There is a tiny chance that serialization could change
    -- for Metadata in the future, depending on the era it is being used in. For now
    -- we can pretend like it is the same for all eras starting with Shelley
    --
    -- Versioned cbor works only when we have protocol version available during
    -- [de]serialization. The only two ways to fix this:
    --
    -- - Paramterize TxMetadata with era. This would allow us to get protocol version
    --   from the type level
    --
    -- - Change SerialiseAsCBOR interface in such a way that it allows major
    --   protocol version be supplied as an argument.
    Version -> Map Word64 Metadatum -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
CBOR.serialize' Version
CBOR.shelleyProtVer
      (Map Word64 Metadatum -> ByteString)
-> (TxMetadata -> Map Word64 Metadatum) -> TxMetadata -> ByteString
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
unTxMetadata

  deserialiseFromCBOR :: AsType TxMetadata -> ByteString -> Either DecoderError TxMetadata
deserialiseFromCBOR AsType TxMetadata
R:AsTypeTxMetadata
AsTxMetadata ByteString
bs =
    Map Word64 TxMetadataValue -> TxMetadata
TxMetadata
      (Map Word64 TxMetadataValue -> TxMetadata)
-> (Map Word64 Metadatum -> Map Word64 TxMetadataValue)
-> Map Word64 Metadatum
-> TxMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Word64 Metadatum -> Map Word64 TxMetadataValue
fromShelleyMetadata
      (Map Word64 Metadatum -> TxMetadata)
-> Either DecoderError (Map Word64 Metadatum)
-> Either DecoderError TxMetadata
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( Version
-> Text
-> (forall s. Decoder s (Map Word64 Metadatum))
-> ByteString
-> Either DecoderError (Map Word64 Metadatum)
forall a.
Version
-> Text
-> (forall s. Decoder s a)
-> ByteString
-> Either DecoderError a
CBOR.decodeFullDecoder' Version
CBOR.shelleyProtVer Text
"TxMetadata" Decoder s (Map Word64 Metadatum)
forall s. Decoder s (Map Word64 Metadatum)
forall a s. DecCBOR a => Decoder s a
CBOR.decCBOR ByteString
bs
              :: Either CBOR.DecoderError (Map Word64 Shelley.Metadatum)
          )

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

mergeTransactionMetadata
  :: (TxMetadataValue -> TxMetadataValue -> TxMetadataValue)
  -> TxMetadata
  -> TxMetadata
  -> TxMetadata
mergeTransactionMetadata :: (TxMetadataValue -> TxMetadataValue -> TxMetadataValue)
-> TxMetadata -> TxMetadata -> TxMetadata
mergeTransactionMetadata TxMetadataValue -> TxMetadataValue -> TxMetadataValue
merge (TxMetadata Map Word64 TxMetadataValue
m1) (TxMetadata Map Word64 TxMetadataValue
m2) =
  Map Word64 TxMetadataValue -> TxMetadata
TxMetadata (Map Word64 TxMetadataValue -> TxMetadata)
-> Map Word64 TxMetadataValue -> TxMetadata
forall a b. (a -> b) -> a -> b
$ (TxMetadataValue -> TxMetadataValue -> TxMetadataValue)
-> Map Word64 TxMetadataValue
-> Map Word64 TxMetadataValue
-> Map Word64 TxMetadataValue
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith TxMetadataValue -> TxMetadataValue -> TxMetadataValue
merge Map Word64 TxMetadataValue
m1 Map Word64 TxMetadataValue
m2

-- | Create a 'TxMetadataValue' from a 'Text' as a list of chunks of an
-- acceptable size.
metaTextChunks :: Text -> TxMetadataValue
metaTextChunks :: Text -> TxMetadataValue
metaTextChunks =
  [TxMetadataValue] -> TxMetadataValue
TxMetaList
    ([TxMetadataValue] -> TxMetadataValue)
-> (Text -> [TxMetadataValue]) -> Text -> TxMetadataValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> (Text -> TxMetadataValue)
-> (Text -> Int)
-> (Int -> Text -> (Text, Text))
-> Text
-> [TxMetadataValue]
forall str chunk.
Int
-> (str -> chunk)
-> (str -> Int)
-> (Int -> str -> (str, str))
-> str
-> [chunk]
chunks
      Int
txMetadataTextStringMaxByteLength
      Text -> TxMetadataValue
TxMetaText
      (ByteString -> Int
BS.length (ByteString -> Int) -> (Text -> ByteString) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8)
      Int -> Text -> (Text, Text)
utf8SplitAt
 where
  fromBuilder :: Builder -> Text
fromBuilder = LazyText -> Text
Text.Lazy.toStrict (LazyText -> Text) -> (Builder -> LazyText) -> Builder -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyText
Text.Builder.toLazyText

  -- 'Text.splitAt' is no good here, because our measurement is on UTF-8
  -- encoded text strings; So a char of size 1 in a text string may be
  -- encoded over multiple UTF-8 bytes.
  --
  -- Thus, no choice than folding over each char and manually implementing
  -- splitAt that counts utf8 bytes. Using builders for slightly more
  -- efficiency.
  utf8SplitAt :: Int -> Text -> (Text, Text)
utf8SplitAt Int
n =
    (Builder -> Text)
-> (Builder -> Text) -> (Builder, Builder) -> (Text, Text)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Builder -> Text
fromBuilder Builder -> Text
fromBuilder
      ((Builder, Builder) -> (Text, Text))
-> (Text -> (Builder, Builder)) -> Text -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, (Builder, Builder)) -> (Builder, Builder)
forall a b. (a, b) -> b
snd
      ((Int, (Builder, Builder)) -> (Builder, Builder))
-> (Text -> (Int, (Builder, Builder)))
-> Text
-> (Builder, Builder)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, (Builder, Builder)) -> Char -> (Int, (Builder, Builder)))
-> (Int, (Builder, Builder)) -> Text -> (Int, (Builder, Builder))
forall a. (a -> Char -> a) -> a -> Text -> a
Text.foldl
        ( \(Int
len, (Builder
left, Builder
right)) Char
char ->
            -- NOTE:
            -- Starting from text >= 2.0.0.0, one can use:
            --
            --   Data.Text.Internal.Encoding.Utf8#utf8Length
            --
            let sz :: Int
sz = ByteString -> Int
BS.length (Text -> ByteString
Text.encodeUtf8 (Char -> Text
Text.singleton Char
char))
             in if Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n
                  then
                    ( Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -- Higher than 'n' to always trigger the predicate
                    ,
                      ( Builder
left
                      , Builder
right Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Text.Builder.singleton Char
char
                      )
                    )
                  else
                    ( Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz
                    ,
                      ( Builder
left Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Text.Builder.singleton Char
char
                      , Builder
right
                      )
                    )
        )
        (Int
0, (Builder
forall a. Monoid a => a
mempty, Builder
forall a. Monoid a => a
mempty))

-- | Create a 'TxMetadataValue' from a 'ByteString' as a list of chunks of an
-- accaptable size.
metaBytesChunks :: ByteString -> TxMetadataValue
metaBytesChunks :: ByteString -> TxMetadataValue
metaBytesChunks =
  [TxMetadataValue] -> TxMetadataValue
TxMetaList
    ([TxMetadataValue] -> TxMetadataValue)
-> (ByteString -> [TxMetadataValue])
-> ByteString
-> TxMetadataValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> (ByteString -> TxMetadataValue)
-> (ByteString -> Int)
-> (Int -> ByteString -> (ByteString, ByteString))
-> ByteString
-> [TxMetadataValue]
forall str chunk.
Int
-> (str -> chunk)
-> (str -> Int)
-> (Int -> str -> (str, str))
-> str
-> [chunk]
chunks
      Int
txMetadataByteStringMaxLength
      ByteString -> TxMetadataValue
TxMetaBytes
      ByteString -> Int
BS.length
      Int -> ByteString -> (ByteString, ByteString)
BS.splitAt

-- ----------------------------------------------------------------------------
-- TxMetadata class
--

class AsTxMetadata a where
  asTxMetadata :: a -> 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
    ]

-- | Transform a string-like structure into chunks with a maximum size; Chunks
-- are filled from left to right.
chunks
  :: Int
  -- ^ Chunk max size (inclusive)
  -> (str -> chunk)
  -- ^ Hoisting
  -> (str -> Int)
  -- ^ Measuring
  -> (Int -> str -> (str, str))
  -- ^ Splitting
  -> str
  -- ^ String
  -> [chunk]
chunks :: forall str chunk.
Int
-> (str -> chunk)
-> (str -> Int)
-> (Int -> str -> (str, str))
-> str
-> [chunk]
chunks Int
maxLength str -> chunk
strHoist str -> Int
strLength Int -> str -> (str, str)
strSplitAt str
str
  | str -> Int
strLength str
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
maxLength =
      let (str
h, str
t) = Int -> str -> (str, str)
strSplitAt Int
maxLength str
str
       in str -> chunk
strHoist str
h chunk -> [chunk] -> [chunk]
forall a. a -> [a] -> [a]
: Int
-> (str -> chunk)
-> (str -> Int)
-> (Int -> str -> (str, str))
-> str
-> [chunk]
forall str chunk.
Int
-> (str -> chunk)
-> (str -> Int)
-> (Int -> str -> (str, str))
-> str
-> [chunk]
chunks Int
maxLength str -> chunk
strHoist str -> Int
strLength Int -> str -> (str, str)
strSplitAt str
t
  | Bool
otherwise =
      [str -> chunk
strHoist str
str | str -> Int
strLength str
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0]

-- ----------------------------------------------------------------------------
-- 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 -> [Item (Map Word64 TxMetadataValue)]
forall l. IsList l => l -> [Item l]
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 m a. Monoid m => (a -> m) -> [a] -> m
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 m a. Monoid m => (a -> m) -> [a] -> m
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
$c== :: TxMetadataRangeError -> TxMetadataRangeError -> Bool
== :: TxMetadataRangeError -> TxMetadataRangeError -> Bool
$c/= :: TxMetadataRangeError -> TxMetadataRangeError -> Bool
/= :: 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
$cshowsPrec :: Int -> TxMetadataRangeError -> ShowS
showsPrec :: Int -> TxMetadataRangeError -> ShowS
$cshow :: TxMetadataRangeError -> String
show :: TxMetadataRangeError -> String
$cshowList :: [TxMetadataRangeError] -> ShowS
showList :: [TxMetadataRangeError] -> ShowS
Show, Typeable TxMetadataRangeError
Typeable TxMetadataRangeError =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g)
 -> TxMetadataRangeError
 -> c TxMetadataRangeError)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c TxMetadataRangeError)
-> (TxMetadataRangeError -> Constr)
-> (TxMetadataRangeError -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c TxMetadataRangeError))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c TxMetadataRangeError))
-> ((forall b. Data b => b -> b)
    -> TxMetadataRangeError -> TxMetadataRangeError)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> TxMetadataRangeError -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> TxMetadataRangeError -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> TxMetadataRangeError -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> TxMetadataRangeError -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> TxMetadataRangeError -> m TxMetadataRangeError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> TxMetadataRangeError -> m TxMetadataRangeError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> TxMetadataRangeError -> m TxMetadataRangeError)
-> Data TxMetadataRangeError
TxMetadataRangeError -> Constr
TxMetadataRangeError -> DataType
(forall b. Data b => b -> b)
-> TxMetadataRangeError -> TxMetadataRangeError
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> TxMetadataRangeError -> u
forall u.
(forall d. Data d => d -> u) -> TxMetadataRangeError -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataRangeError -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataRangeError -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> TxMetadataRangeError -> m TxMetadataRangeError
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataRangeError -> m TxMetadataRangeError
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TxMetadataRangeError
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> TxMetadataRangeError
-> c TxMetadataRangeError
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TxMetadataRangeError)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c TxMetadataRangeError)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> TxMetadataRangeError
-> c TxMetadataRangeError
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> TxMetadataRangeError
-> c TxMetadataRangeError
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TxMetadataRangeError
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TxMetadataRangeError
$ctoConstr :: TxMetadataRangeError -> Constr
toConstr :: TxMetadataRangeError -> Constr
$cdataTypeOf :: TxMetadataRangeError -> DataType
dataTypeOf :: TxMetadataRangeError -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TxMetadataRangeError)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TxMetadataRangeError)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c TxMetadataRangeError)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c TxMetadataRangeError)
$cgmapT :: (forall b. Data b => b -> b)
-> TxMetadataRangeError -> TxMetadataRangeError
gmapT :: (forall b. Data b => b -> b)
-> TxMetadataRangeError -> TxMetadataRangeError
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataRangeError -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataRangeError -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataRangeError -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataRangeError -> r
$cgmapQ :: forall u.
(forall d. Data d => d -> u) -> TxMetadataRangeError -> [u]
gmapQ :: forall u.
(forall d. Data d => d -> u) -> TxMetadataRangeError -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> TxMetadataRangeError -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> TxMetadataRangeError -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> TxMetadataRangeError -> m TxMetadataRangeError
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> TxMetadataRangeError -> m TxMetadataRangeError
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataRangeError -> m TxMetadataRangeError
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataRangeError -> m TxMetadataRangeError
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataRangeError -> m TxMetadataRangeError
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataRangeError -> m TxMetadataRangeError
Data)

instance Error TxMetadataRangeError where
  prettyError :: forall ann. TxMetadataRangeError -> Doc ann
prettyError = \case
    TxMetadataNumberOutOfRange Integer
n ->
      Doc ann
"Numeric metadata value "
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Integer -> Doc ann
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
n
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" is outside the range -(2^64-1) .. 2^64-1."
    TxMetadataTextTooLong Int
actualLen ->
      Doc ann
"Text string metadata value must consist of at most "
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
txMetadataTextStringMaxByteLength
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" UTF8 bytes, but it consists of "
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
actualLen
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" bytes."
    TxMetadataBytesTooLong Int
actualLen ->
      Doc ann
"Byte string metadata value must consist of at most "
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
txMetadataByteStringMaxLength
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" bytes, but it consists of "
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
actualLen
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" 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
$c== :: TxMetadataJsonSchema -> TxMetadataJsonSchema -> Bool
== :: TxMetadataJsonSchema -> TxMetadataJsonSchema -> Bool
$c/= :: TxMetadataJsonSchema -> TxMetadataJsonSchema -> Bool
/= :: 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
$cshowsPrec :: Int -> TxMetadataJsonSchema -> ShowS
showsPrec :: Int -> TxMetadataJsonSchema -> ShowS
$cshow :: TxMetadataJsonSchema -> String
show :: TxMetadataJsonSchema -> String
$cshowList :: [TxMetadataJsonSchema] -> ShowS
showList :: [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 =
  \case
    -- 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 a b.
(a -> b)
-> Either TxMetadataJsonError a -> Either TxMetadataJsonError b
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
[Item (Map Word64 TxMetadataValue)] -> Map Word64 TxMetadataValue
forall l. IsList l => [Item l] -> l
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 -> [Item Object]
forall l. IsList l => l -> [Item l]
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 a b c. (a -> b) -> Either a c -> Either b c
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 a b c. (a -> b) -> Either a c -> Either b c
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 a. a -> Either TxMetadataJsonError a
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 a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
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 -> [Item (Map Word64 TxMetadataValue)]
forall l. IsList l => l -> [Item l]
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 ([Item Array] -> Array
forall l. IsList l => [Item l] -> l
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
. LazyText -> Text
Text.Lazy.toStrict
      (LazyText -> Text)
-> (TxMetadataValue -> LazyText) -> TxMetadataValue -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> LazyText
forall a. ToJSON a => a -> LazyText
Aeson.Text.encodeToLazyText
      (Value -> LazyText)
-> (TxMetadataValue -> Value) -> TxMetadataValue -> LazyText
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 a b.
(a -> b)
-> Either TxMetadataJsonSchemaError a
-> Either TxMetadataJsonSchemaError b
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Value -> Either TxMetadataJsonSchemaError TxMetadataValue
conv
      ([Value] -> Either TxMetadataJsonSchemaError TxMetadataValue)
-> [Value] -> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b. (a -> b) -> a -> b
$ Array -> [Item Array]
forall l. IsList l => l -> [Item l]
toList Array
vs
  conv (Aeson.Object Object
kvs) =
    ([(TxMetadataValue, TxMetadataValue)] -> TxMetadataValue)
-> Either
     TxMetadataJsonSchemaError [(TxMetadataValue, TxMetadataValue)]
-> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b.
(a -> b)
-> Either TxMetadataJsonSchemaError a
-> Either TxMetadataJsonSchemaError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      ( [(TxMetadataValue, TxMetadataValue)] -> TxMetadataValue
TxMetaMap
          ([(TxMetadataValue, TxMetadataValue)] -> TxMetadataValue)
-> ([(TxMetadataValue, TxMetadataValue)]
    -> [(TxMetadataValue, TxMetadataValue)])
-> [(TxMetadataValue, TxMetadataValue)]
-> TxMetadataValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(TxMetadataValue, TxMetadataValue)]
-> [(TxMetadataValue, TxMetadataValue)]
sortCanonicalForCbor
      )
      (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
. ((Key, Value)
 -> Either
      TxMetadataJsonSchemaError (TxMetadataValue, TxMetadataValue))
-> [(Key, Value)]
-> Either
     TxMetadataJsonSchemaError [(TxMetadataValue, TxMetadataValue)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
        ((\(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
. (Key -> Text) -> (Key, Value) -> (Text, Value)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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 -> [Item Object]
forall l. IsList l => l -> [Item l]
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 a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
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 a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
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 a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((ByteString -> TxMetadataValue)
-> Parser ByteString ByteString -> Parser TxMetadataValue
forall a b. (a -> b) -> Parser ByteString a -> Parser ByteString b
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 a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
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"

-- | Sorts the list by the first value in the tuple using the rules for canonical CBOR (RFC 7049 section 3.9)
--
-- This function is used when transforming data from JSON. In principle the JSON standard and aeson library
-- do not provide any guarantees about the order of keys in 'Aeson.Object' which means we are free to pick any.
-- Because we're dumping data into CBOR we are picking a canonical way of sorting keys in a map - the keys are
-- sorted according to the value of their byte representation.
--
-- Details described here: https://datatracker.ietf.org/doc/html/rfc7049#section-3.9
sortCanonicalForCbor
  :: [(TxMetadataValue, TxMetadataValue)]
  -> [(TxMetadataValue, TxMetadataValue)]
sortCanonicalForCbor :: [(TxMetadataValue, TxMetadataValue)]
-> [(TxMetadataValue, TxMetadataValue)]
sortCanonicalForCbor =
  ((Integer, (TxMetadataValue, TxMetadataValue))
 -> (TxMetadataValue, TxMetadataValue))
-> [(Integer, (TxMetadataValue, TxMetadataValue))]
-> [(TxMetadataValue, TxMetadataValue)]
forall a b. (a -> b) -> [a] -> [b]
map (Integer, (TxMetadataValue, TxMetadataValue))
-> (TxMetadataValue, TxMetadataValue)
forall a b. (a, b) -> b
snd
    ([(Integer, (TxMetadataValue, TxMetadataValue))]
 -> [(TxMetadataValue, TxMetadataValue)])
-> ([(TxMetadataValue, TxMetadataValue)]
    -> [(Integer, (TxMetadataValue, TxMetadataValue))])
-> [(TxMetadataValue, TxMetadataValue)]
-> [(TxMetadataValue, TxMetadataValue)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Integer, (TxMetadataValue, TxMetadataValue)) -> Integer)
-> [(Integer, (TxMetadataValue, TxMetadataValue))]
-> [(Integer, (TxMetadataValue, TxMetadataValue))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Integer, (TxMetadataValue, TxMetadataValue)) -> Integer
forall a b. (a, b) -> a
fst
    ([(Integer, (TxMetadataValue, TxMetadataValue))]
 -> [(Integer, (TxMetadataValue, TxMetadataValue))])
-> ([(TxMetadataValue, TxMetadataValue)]
    -> [(Integer, (TxMetadataValue, TxMetadataValue))])
-> [(TxMetadataValue, TxMetadataValue)]
-> [(Integer, (TxMetadataValue, TxMetadataValue))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TxMetadataValue, TxMetadataValue)
 -> (Integer, (TxMetadataValue, TxMetadataValue)))
-> [(TxMetadataValue, TxMetadataValue)]
-> [(Integer, (TxMetadataValue, TxMetadataValue))]
forall a b. (a -> b) -> [a] -> [b]
map (\e :: (TxMetadataValue, TxMetadataValue)
e@(TxMetadataValue
k, TxMetadataValue
_) -> (ByteString -> Integer
CBOR.uintegerFromBytes (ByteString -> Integer) -> ByteString -> Integer
forall a b. (a -> b) -> a -> b
$ TxMetadataValue -> ByteString
serialiseKey TxMetadataValue
k, (TxMetadataValue, TxMetadataValue)
e))
 where
  serialiseKey :: TxMetadataValue -> ByteString
serialiseKey = Version -> Metadatum -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
CBOR.serialize' Version
CBOR.shelleyProtVer (Metadatum -> ByteString)
-> (TxMetadataValue -> Metadatum) -> TxMetadataValue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxMetadataValue -> Metadatum
toShelleyMetadatum

-- ----------------------------------------------------------------------------
-- 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
$ [Item Array] -> Array
forall l. IsList l => [Item l] -> l
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
$ [Item Array] -> Array
forall l. IsList l => [Item l] -> l
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 -> [Item Object]
forall l. IsList l => l -> [Item l]
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 a b.
(a -> b)
-> Either TxMetadataJsonSchemaError a
-> Either TxMetadataJsonSchemaError b
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Value -> Either TxMetadataJsonSchemaError TxMetadataValue
conv
          ([Value] -> Either TxMetadataJsonSchemaError TxMetadataValue)
-> [Value] -> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b. (a -> b) -> a -> b
$ Array -> [Item Array]
forall l. IsList l => l -> [Item l]
toList Array
vs
      [(Key
"map", Aeson.Array Array
kvs)] ->
        ([(TxMetadataValue, TxMetadataValue)] -> TxMetadataValue)
-> Either
     TxMetadataJsonSchemaError [(TxMetadataValue, TxMetadataValue)]
-> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b.
(a -> b)
-> Either TxMetadataJsonSchemaError a
-> Either TxMetadataJsonSchemaError b
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Value
-> Either
     TxMetadataJsonSchemaError (TxMetadataValue, TxMetadataValue)
convKeyValuePair
          ([Value] -> Either TxMetadataJsonSchemaError TxMetadataValue)
-> [Value] -> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b. (a -> b) -> a -> b
$ Array -> [Item Array]
forall l. IsList l => l -> [Item l]
toList Array
kvs
      [(Key
key, Value
v)]
        | Key
key Key -> [Key] -> Bool
forall a. Eq a => a -> [a] -> 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)
      [Item Object]
kvs -> TxMetadataJsonSchemaError
-> Either TxMetadataJsonSchemaError TxMetadataValue
forall a b. a -> Either a b
Left ([(Text, Value)] -> TxMetadataJsonSchemaError
TxMetadataJsonBadObject ((Key -> Text) -> (Key, Value) -> (Text, Value)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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)]
[Item Object]
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 a b.
Either TxMetadataJsonSchemaError (a -> b)
-> Either TxMetadataJsonSchemaError a
-> Either TxMetadataJsonSchemaError b
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
$c== :: TxMetadataJsonError -> TxMetadataJsonError -> Bool
== :: TxMetadataJsonError -> TxMetadataJsonError -> Bool
$c/= :: TxMetadataJsonError -> TxMetadataJsonError -> Bool
/= :: 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
$cshowsPrec :: Int -> TxMetadataJsonError -> ShowS
showsPrec :: Int -> TxMetadataJsonError -> ShowS
$cshow :: TxMetadataJsonError -> String
show :: TxMetadataJsonError -> String
$cshowList :: [TxMetadataJsonError] -> ShowS
showList :: [TxMetadataJsonError] -> ShowS
Show, Typeable TxMetadataJsonError
Typeable TxMetadataJsonError =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g)
 -> TxMetadataJsonError
 -> c TxMetadataJsonError)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c TxMetadataJsonError)
-> (TxMetadataJsonError -> Constr)
-> (TxMetadataJsonError -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c TxMetadataJsonError))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c TxMetadataJsonError))
-> ((forall b. Data b => b -> b)
    -> TxMetadataJsonError -> TxMetadataJsonError)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> TxMetadataJsonError -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> TxMetadataJsonError -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> TxMetadataJsonError -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> TxMetadataJsonError -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> TxMetadataJsonError -> m TxMetadataJsonError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> TxMetadataJsonError -> m TxMetadataJsonError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> TxMetadataJsonError -> m TxMetadataJsonError)
-> Data TxMetadataJsonError
TxMetadataJsonError -> Constr
TxMetadataJsonError -> DataType
(forall b. Data b => b -> b)
-> TxMetadataJsonError -> TxMetadataJsonError
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> TxMetadataJsonError -> u
forall u.
(forall d. Data d => d -> u) -> TxMetadataJsonError -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataJsonError -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataJsonError -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonError -> m TxMetadataJsonError
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonError -> m TxMetadataJsonError
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TxMetadataJsonError
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> TxMetadataJsonError
-> c TxMetadataJsonError
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TxMetadataJsonError)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c TxMetadataJsonError)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> TxMetadataJsonError
-> c TxMetadataJsonError
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> TxMetadataJsonError
-> c TxMetadataJsonError
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TxMetadataJsonError
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TxMetadataJsonError
$ctoConstr :: TxMetadataJsonError -> Constr
toConstr :: TxMetadataJsonError -> Constr
$cdataTypeOf :: TxMetadataJsonError -> DataType
dataTypeOf :: TxMetadataJsonError -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TxMetadataJsonError)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c TxMetadataJsonError)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c TxMetadataJsonError)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c TxMetadataJsonError)
$cgmapT :: (forall b. Data b => b -> b)
-> TxMetadataJsonError -> TxMetadataJsonError
gmapT :: (forall b. Data b => b -> b)
-> TxMetadataJsonError -> TxMetadataJsonError
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataJsonError -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataJsonError -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataJsonError -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> TxMetadataJsonError -> r
$cgmapQ :: forall u.
(forall d. Data d => d -> u) -> TxMetadataJsonError -> [u]
gmapQ :: forall u.
(forall d. Data d => d -> u) -> TxMetadataJsonError -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> TxMetadataJsonError -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> TxMetadataJsonError -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonError -> m TxMetadataJsonError
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonError -> m TxMetadataJsonError
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonError -> m TxMetadataJsonError
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonError -> m TxMetadataJsonError
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonError -> m TxMetadataJsonError
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonError -> m TxMetadataJsonError
Data)

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
$c== :: TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError -> Bool
== :: TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError -> Bool
$c/= :: TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError -> Bool
/= :: 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
$cshowsPrec :: Int -> TxMetadataJsonSchemaError -> ShowS
showsPrec :: Int -> TxMetadataJsonSchemaError -> ShowS
$cshow :: TxMetadataJsonSchemaError -> String
show :: TxMetadataJsonSchemaError -> String
$cshowList :: [TxMetadataJsonSchemaError] -> ShowS
showList :: [TxMetadataJsonSchemaError] -> ShowS
Show, Typeable TxMetadataJsonSchemaError
Typeable TxMetadataJsonSchemaError =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g)
 -> TxMetadataJsonSchemaError
 -> c TxMetadataJsonSchemaError)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c TxMetadataJsonSchemaError)
-> (TxMetadataJsonSchemaError -> Constr)
-> (TxMetadataJsonSchemaError -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d))
    -> Maybe (c TxMetadataJsonSchemaError))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c TxMetadataJsonSchemaError))
-> ((forall b. Data b => b -> b)
    -> TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError)
-> (forall r r'.
    (r -> r' -> r)
    -> r
    -> (forall d. Data d => d -> r')
    -> TxMetadataJsonSchemaError
    -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r
    -> (forall d. Data d => d -> r')
    -> TxMetadataJsonSchemaError
    -> r)
-> (forall u.
    (forall d. Data d => d -> u) -> TxMetadataJsonSchemaError -> [u])
-> (forall u.
    Int
    -> (forall d. Data d => d -> u) -> TxMetadataJsonSchemaError -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d)
    -> TxMetadataJsonSchemaError -> m TxMetadataJsonSchemaError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> TxMetadataJsonSchemaError -> m TxMetadataJsonSchemaError)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d)
    -> TxMetadataJsonSchemaError -> m TxMetadataJsonSchemaError)
-> Data TxMetadataJsonSchemaError
TxMetadataJsonSchemaError -> Constr
TxMetadataJsonSchemaError -> DataType
(forall b. Data b => b -> b)
-> TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int
-> (forall d. Data d => d -> u) -> TxMetadataJsonSchemaError -> u
forall u.
(forall d. Data d => d -> u) -> TxMetadataJsonSchemaError -> [u]
forall r r'.
(r -> r' -> r)
-> r
-> (forall d. Data d => d -> r')
-> TxMetadataJsonSchemaError
-> r
forall r r'.
(r' -> r -> r)
-> r
-> (forall d. Data d => d -> r')
-> TxMetadataJsonSchemaError
-> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonSchemaError -> m TxMetadataJsonSchemaError
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonSchemaError -> m TxMetadataJsonSchemaError
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TxMetadataJsonSchemaError
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> TxMetadataJsonSchemaError
-> c TxMetadataJsonSchemaError
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d))
-> Maybe (c TxMetadataJsonSchemaError)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c TxMetadataJsonSchemaError)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> TxMetadataJsonSchemaError
-> c TxMetadataJsonSchemaError
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> TxMetadataJsonSchemaError
-> c TxMetadataJsonSchemaError
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TxMetadataJsonSchemaError
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c TxMetadataJsonSchemaError
$ctoConstr :: TxMetadataJsonSchemaError -> Constr
toConstr :: TxMetadataJsonSchemaError -> Constr
$cdataTypeOf :: TxMetadataJsonSchemaError -> DataType
dataTypeOf :: TxMetadataJsonSchemaError -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d))
-> Maybe (c TxMetadataJsonSchemaError)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d))
-> Maybe (c TxMetadataJsonSchemaError)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c TxMetadataJsonSchemaError)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c TxMetadataJsonSchemaError)
$cgmapT :: (forall b. Data b => b -> b)
-> TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError
gmapT :: (forall b. Data b => b -> b)
-> TxMetadataJsonSchemaError -> TxMetadataJsonSchemaError
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r
-> (forall d. Data d => d -> r')
-> TxMetadataJsonSchemaError
-> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r
-> (forall d. Data d => d -> r')
-> TxMetadataJsonSchemaError
-> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r
-> (forall d. Data d => d -> r')
-> TxMetadataJsonSchemaError
-> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r
-> (forall d. Data d => d -> r')
-> TxMetadataJsonSchemaError
-> r
$cgmapQ :: forall u.
(forall d. Data d => d -> u) -> TxMetadataJsonSchemaError -> [u]
gmapQ :: forall u.
(forall d. Data d => d -> u) -> TxMetadataJsonSchemaError -> [u]
$cgmapQi :: forall u.
Int
-> (forall d. Data d => d -> u) -> TxMetadataJsonSchemaError -> u
gmapQi :: forall u.
Int
-> (forall d. Data d => d -> u) -> TxMetadataJsonSchemaError -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonSchemaError -> m TxMetadataJsonSchemaError
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonSchemaError -> m TxMetadataJsonSchemaError
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonSchemaError -> m TxMetadataJsonSchemaError
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonSchemaError -> m TxMetadataJsonSchemaError
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonSchemaError -> m TxMetadataJsonSchemaError
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> TxMetadataJsonSchemaError -> m TxMetadataJsonSchemaError
Data)

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

instance Error TxMetadataJsonSchemaError where
  prettyError :: forall ann. TxMetadataJsonSchemaError -> Doc ann
prettyError = \case
    TxMetadataJsonSchemaError
TxMetadataJsonNullNotAllowed ->
      Doc ann
"JSON null values are not supported."
    TxMetadataJsonSchemaError
TxMetadataJsonBoolNotAllowed ->
      Doc ann
"JSON bool values are not supported."
    TxMetadataJsonNumberNotInteger Double
d ->
      Doc ann
"JSON numbers must be integers. Unexpected value: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Double -> Doc ann
forall ann. Double -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Double
d
    TxMetadataJsonNotObject Value
v ->
      Doc ann
"JSON object expected. Unexpected value: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> String
LBS.unpack (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
v))
    TxMetadataJsonBadObject [(Text, Value)]
v ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"JSON object does not match the schema.\nExpected a single field named "
        , Doc ann
"\"int\", \"bytes\", \"string\", \"list\" or \"map\".\n"
        , Doc ann
"Unexpected object field(s): "
        , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> String
LBS.unpack (Value -> ByteString
forall a. ToJSON a => a -> ByteString
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 a b c. (a -> b) -> (a, c) -> (b, c)
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)))
        ]
    TxMetadataJsonBadMapPair Value
v ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"Expected a list of key/value pair { \"k\": ..., \"v\": ... } objects."
        , Doc ann
"\nUnexpected value: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> String
LBS.unpack (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode Value
v))
        ]
    TxMetadataJsonTypeMismatch Text
k Value
v ->
      [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
        [ Doc ann
"The value in the field " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
k Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" does not have the type "
        , Doc ann
"required by the schema.\nUnexpected value: "
        , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> String
LBS.unpack (Value -> ByteString
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 =
  (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 a. a -> Parser ByteString a
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 a. String -> Parser ByteString a
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 a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
    Either String ByteString
_ -> String -> Parser ByteString ByteString
forall a. String -> Parser ByteString a
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'