{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Ledger.Metadata (
  Metadatum (..),
  validMetadatum,
) where

import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  Decoder,
  DecoderError (..),
  EncCBOR (encCBOR),
  Encoding,
  TokenType (..),
  cborError,
  decodeBreakOr,
  decodeBytes,
  decodeBytesIndef,
  decodeInteger,
  decodeListLen,
  decodeListLenIndef,
  decodeMapLen,
  decodeMapLenIndef,
  decodeString,
  decodeStringIndef,
  encodeBytes,
  encodeInteger,
  encodeListLen,
  encodeMapLen,
  encodeString,
  peekTokenType,
 )
import Control.DeepSeq (NFData (rnf))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))

-- | A generic metadatum type.
data Metadatum
  = Map ![(Metadatum, Metadatum)]
  | List ![Metadatum]
  | I !Integer
  | B !BS.ByteString
  | S !T.Text
  deriving stock (Int -> Metadatum -> ShowS
[Metadatum] -> ShowS
Metadatum -> String
(Int -> Metadatum -> ShowS)
-> (Metadatum -> String)
-> ([Metadatum] -> ShowS)
-> Show Metadatum
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Metadatum -> ShowS
showsPrec :: Int -> Metadatum -> ShowS
$cshow :: Metadatum -> String
show :: Metadatum -> String
$cshowList :: [Metadatum] -> ShowS
showList :: [Metadatum] -> ShowS
Show, Metadatum -> Metadatum -> Bool
(Metadatum -> Metadatum -> Bool)
-> (Metadatum -> Metadatum -> Bool) -> Eq Metadatum
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Metadatum -> Metadatum -> Bool
== :: Metadatum -> Metadatum -> Bool
$c/= :: Metadatum -> Metadatum -> Bool
/= :: Metadatum -> Metadatum -> Bool
Eq, Eq Metadatum
Eq Metadatum =>
(Metadatum -> Metadatum -> Ordering)
-> (Metadatum -> Metadatum -> Bool)
-> (Metadatum -> Metadatum -> Bool)
-> (Metadatum -> Metadatum -> Bool)
-> (Metadatum -> Metadatum -> Bool)
-> (Metadatum -> Metadatum -> Metadatum)
-> (Metadatum -> Metadatum -> Metadatum)
-> Ord Metadatum
Metadatum -> Metadatum -> Bool
Metadatum -> Metadatum -> Ordering
Metadatum -> Metadatum -> Metadatum
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 :: Metadatum -> Metadatum -> Ordering
compare :: Metadatum -> Metadatum -> Ordering
$c< :: Metadatum -> Metadatum -> Bool
< :: Metadatum -> Metadatum -> Bool
$c<= :: Metadatum -> Metadatum -> Bool
<= :: Metadatum -> Metadatum -> Bool
$c> :: Metadatum -> Metadatum -> Bool
> :: Metadatum -> Metadatum -> Bool
$c>= :: Metadatum -> Metadatum -> Bool
>= :: Metadatum -> Metadatum -> Bool
$cmax :: Metadatum -> Metadatum -> Metadatum
max :: Metadatum -> Metadatum -> Metadatum
$cmin :: Metadatum -> Metadatum -> Metadatum
min :: Metadatum -> Metadatum -> Metadatum
Ord, (forall x. Metadatum -> Rep Metadatum x)
-> (forall x. Rep Metadatum x -> Metadatum) -> Generic Metadatum
forall x. Rep Metadatum x -> Metadatum
forall x. Metadatum -> Rep Metadatum x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Metadatum -> Rep Metadatum x
from :: forall x. Metadatum -> Rep Metadatum x
$cto :: forall x. Rep Metadatum x -> Metadatum
to :: forall x. Rep Metadatum x -> Metadatum
Generic)

instance NoThunks Metadatum

instance NFData Metadatum where
  rnf :: Metadatum -> ()
rnf = \case
    Map [(Metadatum, Metadatum)]
m -> [(Metadatum, Metadatum)] -> ()
forall a. NFData a => a -> ()
rnf [(Metadatum, Metadatum)]
m
    List [Metadatum]
l -> [Metadatum] -> ()
forall a. NFData a => a -> ()
rnf [Metadatum]
l
    I Integer
_ -> ()
    B ByteString
_ -> ()
    S Text
_ -> ()

instance EncCBOR Metadatum where
  encCBOR :: Metadatum -> Encoding
encCBOR = Metadatum -> Encoding
encodeMetadatum

instance DecCBOR Metadatum where
  decCBOR :: forall s. Decoder s Metadatum
decCBOR = Decoder s Metadatum
forall s. Decoder s Metadatum
decodeMetadatum

-- Validation of sizes

validMetadatum :: Metadatum -> Bool
-- The integer size/representation checks are enforced in the decoder.
validMetadatum :: Metadatum -> Bool
validMetadatum (I Integer
_) = Bool
True
validMetadatum (B ByteString
b) = ByteString -> Int
BS.length ByteString
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
64
validMetadatum (S Text
s) = ByteString -> Int
BS.length (Text -> ByteString
T.encodeUtf8 Text
s) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
64
validMetadatum (List [Metadatum]
xs) = (Metadatum -> Bool) -> [Metadatum] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Metadatum -> Bool
validMetadatum [Metadatum]
xs
validMetadatum (Map [(Metadatum, Metadatum)]
kvs) =
  ((Metadatum, Metadatum) -> Bool)
-> [(Metadatum, Metadatum)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
    ( \(Metadatum
k, Metadatum
v) ->
        Metadatum -> Bool
validMetadatum Metadatum
k
          Bool -> Bool -> Bool
&& Metadatum -> Bool
validMetadatum Metadatum
v
    )
    [(Metadatum, Metadatum)]
kvs

-------------------------------------------------------------------------------
-- CBOR encoding and decoding

encodeMetadatum :: Metadatum -> Encoding
encodeMetadatum :: Metadatum -> Encoding
encodeMetadatum (I Integer
n) = Integer -> Encoding
encodeInteger Integer
n
encodeMetadatum (B ByteString
b) = ByteString -> Encoding
encodeBytes ByteString
b
encodeMetadatum (S Text
s) = Text -> Encoding
encodeString Text
s
encodeMetadatum (List [Metadatum]
xs) =
  Word -> Encoding
encodeListLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Metadatum] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Metadatum]
xs))
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
      [ Metadatum -> Encoding
encodeMetadatum Metadatum
x
      | Metadatum
x <- [Metadatum]
xs
      ]
encodeMetadatum (Map [(Metadatum, Metadatum)]
kvs) =
  Word -> Encoding
encodeMapLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(Metadatum, Metadatum)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Metadatum, Metadatum)]
kvs))
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat
      [ Metadatum -> Encoding
encodeMetadatum Metadatum
k Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Metadatum -> Encoding
encodeMetadatum Metadatum
v
      | (Metadatum
k, Metadatum
v) <- [(Metadatum, Metadatum)]
kvs
      ]

-- | Decode a transaction matadatum value from its CBOR representation.
--
-- The CDDL for the CBOR is
--
-- > transaction_metadatum =
-- >     int
-- >   / bytes .size (0..64)
-- >   / text .size (0..64)
-- >   / [ * transaction_metadatum ]
-- >   / { * transaction_metadatum => transaction_metadatum }
--
-- We do not require canonical representations, just like everywhere else
-- on the chain. We accept both definte and indefinite representations.
--
-- The byte and string length checks are not enforced in this decoder, but
decodeMetadatum :: Decoder s Metadatum
decodeMetadatum :: forall s. Decoder s Metadatum
decodeMetadatum = do
  tkty <- Decoder s TokenType
forall s. Decoder s TokenType
peekTokenType
  case tkty of
    -- We support -(2^64-1) .. 2^64-1, but not big integers
    -- not even big integer representation of values within range
    TokenType
TypeUInt -> Integer -> Metadatum
I (Integer -> Metadatum) -> Decoder s Integer -> Decoder s Metadatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
decodeInteger
    TokenType
TypeUInt64 -> Integer -> Metadatum
I (Integer -> Metadatum) -> Decoder s Integer -> Decoder s Metadatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
decodeInteger
    TokenType
TypeNInt -> Integer -> Metadatum
I (Integer -> Metadatum) -> Decoder s Integer -> Decoder s Metadatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
decodeInteger
    TokenType
TypeNInt64 -> Integer -> Metadatum
I (Integer -> Metadatum) -> Decoder s Integer -> Decoder s Metadatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Integer
forall s. Decoder s Integer
decodeInteger
    -- Note that we do not enforce byte and string lengths here in the
    -- decoder. We enforce that in the tx validation rules.
    TokenType
TypeBytes -> do
      !x <- Decoder s ByteString
forall s. Decoder s ByteString
decodeBytes
      return (B x)
    TokenType
TypeBytesIndef -> do
      Decoder s ()
forall s. Decoder s ()
decodeBytesIndef
      !x <- [ByteString] -> Decoder s ByteString
forall s. [ByteString] -> Decoder s ByteString
decodeBytesIndefLen []
      return (B x)
    TokenType
TypeString -> do
      !x <- Decoder s Text
forall s. Decoder s Text
decodeString
      return (S x)
    TokenType
TypeStringIndef -> do
      Decoder s ()
forall s. Decoder s ()
decodeStringIndef
      !x <- [Text] -> Decoder s Text
forall s. [Text] -> Decoder s Text
decodeStringIndefLen []
      return (S x)

    -- Why does it work to do the same thing here for 32 and 64bit list len
    -- tokens? On 32bit systems the decodeListLen will fail if the value
    -- really is bigger than maxBound :: Int, and on 64bit systems if a value
    -- that big is provided, then it'll fail when it runs out of input for
    -- such a big list. Hence we can do exactly the same for the 32bit and
    -- 64bit cases.
    TokenType
TypeListLen -> do
      n <- Decoder s Int
forall s. Decoder s Int
decodeListLen
      xs <- decodeListN n []
      return (List xs)
    TokenType
TypeListLen64 -> do
      n <- Decoder s Int
forall s. Decoder s Int
decodeListLen
      xs <- decodeListN n []
      return (List xs)
    TokenType
TypeListLenIndef -> do
      Decoder s ()
forall s. Decoder s ()
decodeListLenIndef
      xs <- [Metadatum] -> Decoder s [Metadatum]
forall s. [Metadatum] -> Decoder s [Metadatum]
decodeListIndefLen []
      return (List xs)

    -- Same logic applies as above for large lists.
    TokenType
TypeMapLen -> do
      n <- Decoder s Int
forall s. Decoder s Int
decodeMapLen
      xs <- decodeMapN n []
      return (Map xs)
    TokenType
TypeMapLen64 -> do
      n <- Decoder s Int
forall s. Decoder s Int
decodeMapLen
      xs <- decodeMapN n []
      return (Map xs)
    TokenType
TypeMapLenIndef -> do
      Decoder s ()
forall s. Decoder s ()
decodeMapLenIndef
      xs <- [(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
forall s.
[(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
decodeMapIndefLen []
      return (Map xs)
    TokenType
_ -> Text -> Decoder s Metadatum
forall {m :: * -> *} {a}. MonadFail m => Text -> m a
decodeError (Text
"Unsupported token type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (TokenType -> String
forall a. Show a => a -> String
show TokenType
tkty))
  where
    decodeError :: Text -> m a
decodeError Text
msg = DecoderError -> m a
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (Text -> Text -> DecoderError
DecoderErrorCustom Text
"metadata" Text
msg)

decodeBytesIndefLen :: [BS.ByteString] -> Decoder s ByteString
decodeBytesIndefLen :: forall s. [ByteString] -> Decoder s ByteString
decodeBytesIndefLen [ByteString]
acc = do
  stop <- Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr
  if stop
    then return $! BS.concat (reverse acc)
    else do
      !bs <- decodeBytes
      decodeBytesIndefLen (bs : acc)

decodeStringIndefLen :: [T.Text] -> Decoder s T.Text
decodeStringIndefLen :: forall s. [Text] -> Decoder s Text
decodeStringIndefLen [Text]
acc = do
  stop <- Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr
  if stop
    then return $! T.concat (reverse acc)
    else do
      !str <- decodeString
      decodeStringIndefLen (str : acc)

decodeListN :: Int -> [Metadatum] -> Decoder s [Metadatum]
decodeListN :: forall s. Int -> [Metadatum] -> Decoder s [Metadatum]
decodeListN !Int
n [Metadatum]
acc =
  case Int
n of
    Int
0 -> [Metadatum] -> Decoder s [Metadatum]
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Metadatum] -> Decoder s [Metadatum])
-> [Metadatum] -> Decoder s [Metadatum]
forall a b. (a -> b) -> a -> b
$! [Metadatum] -> [Metadatum]
forall a. [a] -> [a]
reverse [Metadatum]
acc
    Int
_ -> do
      !t <- Decoder s Metadatum
forall s. Decoder s Metadatum
decodeMetadatum
      decodeListN (n - 1) (t : acc)

decodeListIndefLen :: [Metadatum] -> Decoder s [Metadatum]
decodeListIndefLen :: forall s. [Metadatum] -> Decoder s [Metadatum]
decodeListIndefLen [Metadatum]
acc = do
  stop <- Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr
  if stop
    then return $! reverse acc
    else do
      !tm <- decodeMetadatum
      decodeListIndefLen (tm : acc)

decodeMapN :: Int -> [(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
decodeMapN :: forall s.
Int
-> [(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
decodeMapN !Int
n [(Metadatum, Metadatum)]
acc =
  case Int
n of
    Int
0 -> [(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)])
-> [(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
forall a b. (a -> b) -> a -> b
$! [(Metadatum, Metadatum)] -> [(Metadatum, Metadatum)]
forall a. [a] -> [a]
reverse [(Metadatum, Metadatum)]
acc
    Int
_ -> do
      !tm <- Decoder s Metadatum
forall s. Decoder s Metadatum
decodeMetadatum
      !tm' <- decodeMetadatum
      decodeMapN (n - 1) ((tm, tm') : acc)

decodeMapIndefLen :: [(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
decodeMapIndefLen :: forall s.
[(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
decodeMapIndefLen [(Metadatum, Metadatum)]
acc = do
  stop <- Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr
  if stop
    then return $! reverse acc
    else do
      !tm <- decodeMetadatum
      !tm' <- decodeMetadatum
      decodeMapIndefLen ((tm, tm') : acc)