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

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

import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  Decoder,
  DecoderError (..),
  EncCBOR (encCBOR),
  Encoding,
  TokenType (..),
  cborError,
  decodeBreakOr,
  decodeBytesIndef,
  decodeInteger,
  decodeListLen,
  decodeListLenIndef,
  decodeMapLen,
  decodeMapLenIndef,
  decodeString,
  decodeStringIndef,
  encodeInteger,
  encodeListLen,
  encodeMapLen,
  encodeString,
  getDecoderVersion,
  natVersion,
  peekTokenType,
 )
import Cardano.Ledger.Orphans ()
import Control.DeepSeq (NFData (rnf))
import Control.Monad (when)
import Data.Array.Byte (ByteArray (..))
import qualified Data.Primitive.ByteArray as Prim
import qualified Data.Text as T
import qualified Data.Text.Foreign as TF
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))

-- | A generic metadatum type.
data Metadatum
  = Map ![(Metadatum, Metadatum)]
  | List ![Metadatum]
  | I !Integer
  | B !ByteArray
  | 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 ByteArray
_ -> ()
    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

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

encodeMetadatum :: Metadatum -> Encoding
encodeMetadatum :: Metadatum -> Encoding
encodeMetadatum (I Integer
n) = Integer -> Encoding
encodeInteger Integer
n
encodeMetadatum (B ByteArray
ba) = ByteArray -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ByteArray
ba
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.
--
-- We do not require canonical representations, just like everywhere else
-- on the chain. We accept both definite and indefinite representations.
--
-- The byte and string length checks are enforced in this decoder as per
-- the CDDL spec.
--
-- starting with Allegra era we enforce the length of strings and bytestrings
-- to be no more than 64 bytes
decodeMetadatum :: Decoder s Metadatum
decodeMetadatum :: forall s. Decoder s Metadatum
decodeMetadatum = do
  dv <- Decoder s Version
forall s. Decoder s Version
getDecoderVersion
  let checkSizes = Version
dv Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2
  tkty <- 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
    TokenType
TypeBytes -> do
      !ba <- Decoder s ByteArray
forall s. Decoder s ByteArray
forall a s. DecCBOR a => Decoder s a
decCBOR
      when (checkSizes && Prim.sizeofByteArray ba > 64) $
        decodeError "bytes .size (0..64): bytestring exceeds 64 bytes"
      return (B ba)
    TokenType
TypeBytesIndef -> do
      Decoder s ()
forall s. Decoder s ()
decodeBytesIndef
      !ba <- [ByteArray] -> Decoder s ByteArray
forall s. [ByteArray] -> Decoder s ByteArray
decodeBytesIndefLen []
      when (checkSizes && Prim.sizeofByteArray ba > 64) $
        decodeError "bytes .size (0..64): bytestring exceeds 64 bytes"
      return (B ba)
    TokenType
TypeString -> do
      !x <- Decoder s Text
forall s. Decoder s Text
decodeString
      when (checkSizes && TF.lengthWord8 x > 64) $
        decodeError "text .size (0..64): text exceeds 64 bytes"
      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 []
      when (checkSizes && TF.lengthWord8 x > 64) $
        decodeError "text .size (0..64): text exceeds 64 bytes"
      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 :: [ByteArray] -> Decoder s ByteArray
decodeBytesIndefLen :: forall s. [ByteArray] -> Decoder s ByteArray
decodeBytesIndefLen [ByteArray]
acc = do
  stop <- Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr
  if stop
    then return $! mconcat $ reverse acc
    else do
      !ba <- decCBOR
      decodeBytesIndefLen (ba : 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)