{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Metadatum] -> ShowS
$cshowList :: [Metadatum] -> ShowS
show :: Metadatum -> String
$cshow :: Metadatum -> String
showsPrec :: Int -> Metadatum -> ShowS
$cshowsPrec :: Int -> Metadatum -> ShowS
Show, Metadatum -> Metadatum -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Metadatum -> Metadatum -> Bool
$c/= :: Metadatum -> Metadatum -> Bool
== :: Metadatum -> Metadatum -> Bool
$c== :: Metadatum -> Metadatum -> Bool
Eq, Eq 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
min :: Metadatum -> Metadatum -> Metadatum
$cmin :: Metadatum -> Metadatum -> Metadatum
max :: Metadatum -> Metadatum -> Metadatum
$cmax :: Metadatum -> Metadatum -> Metadatum
>= :: Metadatum -> Metadatum -> Bool
$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
compare :: Metadatum -> Metadatum -> Ordering
$ccompare :: Metadatum -> Metadatum -> Ordering
Ord, 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
$cto :: forall x. Rep Metadatum x -> Metadatum
$cfrom :: forall x. Metadatum -> Rep Metadatum x
Generic)

instance NoThunks Metadatum

instance NFData Metadatum where
  rnf :: Metadatum -> ()
rnf = \case
    Map [(Metadatum, Metadatum)]
m -> forall a. NFData a => a -> ()
rnf [(Metadatum, Metadatum)]
m
    List [Metadatum]
l -> 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 = 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 forall a. Ord a => a -> a -> Bool
<= Int
64
validMetadatum (S Text
s) = ByteString -> Int
BS.length (Text -> ByteString
T.encodeUtf8 Text
s) forall a. Ord a => a -> a -> Bool
<= Int
64
validMetadatum (List [Metadatum]
xs) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Metadatum -> Bool
validMetadatum [Metadatum]
xs
validMetadatum (Map [(Metadatum, Metadatum)]
kvs) =
  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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Metadatum]
xs))
    forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat
      [ Metadatum -> Encoding
encodeMetadatum Metadatum
x
      | Metadatum
x <- [Metadatum]
xs
      ]
encodeMetadatum (Map [(Metadatum, Metadatum)]
kvs) =
  Word -> Encoding
encodeMapLen (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Metadatum, Metadatum)]
kvs))
    forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat
      [ Metadatum -> Encoding
encodeMetadatum Metadatum
k 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
  TokenType
tkty <- forall s. Decoder s TokenType
peekTokenType
  case TokenType
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Integer
decodeInteger
    TokenType
TypeUInt64 -> Integer -> Metadatum
I forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Integer
decodeInteger
    TokenType
TypeNInt -> Integer -> Metadatum
I forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s Integer
decodeInteger
    TokenType
TypeNInt64 -> Integer -> Metadatum
I forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
      !ByteString
x <- forall s. Decoder s ByteString
decodeBytes
      forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Metadatum
B ByteString
x)
    TokenType
TypeBytesIndef -> do
      forall s. Decoder s ()
decodeBytesIndef
      !ByteString
x <- forall s. [ByteString] -> Decoder s ByteString
decodeBytesIndefLen []
      forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Metadatum
B ByteString
x)
    TokenType
TypeString -> do
      !Text
x <- forall s. Decoder s Text
decodeString
      forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Metadatum
S Text
x)
    TokenType
TypeStringIndef -> do
      forall s. Decoder s ()
decodeStringIndef
      !Text
x <- forall s. [Text] -> Decoder s Text
decodeStringIndefLen []
      forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Metadatum
S Text
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
      Int
n <- forall s. Decoder s Int
decodeListLen
      [Metadatum]
xs <- forall s. Int -> [Metadatum] -> Decoder s [Metadatum]
decodeListN Int
n []
      forall (m :: * -> *) a. Monad m => a -> m a
return ([Metadatum] -> Metadatum
List [Metadatum]
xs)
    TokenType
TypeListLen64 -> do
      Int
n <- forall s. Decoder s Int
decodeListLen
      [Metadatum]
xs <- forall s. Int -> [Metadatum] -> Decoder s [Metadatum]
decodeListN Int
n []
      forall (m :: * -> *) a. Monad m => a -> m a
return ([Metadatum] -> Metadatum
List [Metadatum]
xs)
    TokenType
TypeListLenIndef -> do
      forall s. Decoder s ()
decodeListLenIndef
      [Metadatum]
xs <- forall s. [Metadatum] -> Decoder s [Metadatum]
decodeListIndefLen []
      forall (m :: * -> *) a. Monad m => a -> m a
return ([Metadatum] -> Metadatum
List [Metadatum]
xs)

    -- Same logic applies as above for large lists.
    TokenType
TypeMapLen -> do
      Int
n <- forall s. Decoder s Int
decodeMapLen
      [(Metadatum, Metadatum)]
xs <- forall s.
Int
-> [(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
decodeMapN Int
n []
      forall (m :: * -> *) a. Monad m => a -> m a
return ([(Metadatum, Metadatum)] -> Metadatum
Map [(Metadatum, Metadatum)]
xs)
    TokenType
TypeMapLen64 -> do
      Int
n <- forall s. Decoder s Int
decodeMapLen
      [(Metadatum, Metadatum)]
xs <- forall s.
Int
-> [(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
decodeMapN Int
n []
      forall (m :: * -> *) a. Monad m => a -> m a
return ([(Metadatum, Metadatum)] -> Metadatum
Map [(Metadatum, Metadatum)]
xs)
    TokenType
TypeMapLenIndef -> do
      forall s. Decoder s ()
decodeMapLenIndef
      [(Metadatum, Metadatum)]
xs <- forall s.
[(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
decodeMapIndefLen []
      forall (m :: * -> *) a. Monad m => a -> m a
return ([(Metadatum, Metadatum)] -> Metadatum
Map [(Metadatum, Metadatum)]
xs)
    TokenType
_ -> forall {m :: * -> *} {a}. MonadFail m => Text -> m a
decodeError (Text
"Unsupported token type " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show TokenType
tkty))
  where
    decodeError :: Text -> m a
decodeError Text
msg = 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
  Bool
stop <- forall s. Decoder s Bool
decodeBreakOr
  if Bool
stop
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [ByteString] -> ByteString
BS.concat (forall a. [a] -> [a]
reverse [ByteString]
acc)
    else do
      !ByteString
bs <- forall s. Decoder s ByteString
decodeBytes
      forall s. [ByteString] -> Decoder s ByteString
decodeBytesIndefLen (ByteString
bs forall a. a -> [a] -> [a]
: [ByteString]
acc)

decodeStringIndefLen :: [T.Text] -> Decoder s T.Text
decodeStringIndefLen :: forall s. [Text] -> Decoder s Text
decodeStringIndefLen [Text]
acc = do
  Bool
stop <- forall s. Decoder s Bool
decodeBreakOr
  if Bool
stop
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! [Text] -> Text
T.concat (forall a. [a] -> [a]
reverse [Text]
acc)
    else do
      !Text
str <- forall s. Decoder s Text
decodeString
      forall s. [Text] -> Decoder s Text
decodeStringIndefLen (Text
str forall a. a -> [a] -> [a]
: [Text]
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. [a] -> [a]
reverse [Metadatum]
acc
    Int
_ -> do
      !Metadatum
t <- forall s. Decoder s Metadatum
decodeMetadatum
      forall s. Int -> [Metadatum] -> Decoder s [Metadatum]
decodeListN (Int
n forall a. Num a => a -> a -> a
- Int
1) (Metadatum
t forall a. a -> [a] -> [a]
: [Metadatum]
acc)

decodeListIndefLen :: [Metadatum] -> Decoder s [Metadatum]
decodeListIndefLen :: forall s. [Metadatum] -> Decoder s [Metadatum]
decodeListIndefLen [Metadatum]
acc = do
  Bool
stop <- forall s. Decoder s Bool
decodeBreakOr
  if Bool
stop
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. [a] -> [a]
reverse [Metadatum]
acc
    else do
      !Metadatum
tm <- forall s. Decoder s Metadatum
decodeMetadatum
      forall s. [Metadatum] -> Decoder s [Metadatum]
decodeListIndefLen (Metadatum
tm forall a. a -> [a] -> [a]
: [Metadatum]
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. [a] -> [a]
reverse [(Metadatum, Metadatum)]
acc
    Int
_ -> do
      !Metadatum
tm <- forall s. Decoder s Metadatum
decodeMetadatum
      !Metadatum
tm' <- forall s. Decoder s Metadatum
decodeMetadatum
      forall s.
Int
-> [(Metadatum, Metadatum)] -> Decoder s [(Metadatum, Metadatum)]
decodeMapN (Int
n forall a. Num a => a -> a -> a
- Int
1) ((Metadatum
tm, Metadatum
tm') forall a. a -> [a] -> [a]
: [(Metadatum, Metadatum)]
acc)

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