{-# LANGUAGE NamedFieldPuns #-}

module Test.Cardano.Ledger.Shelley.Generator.TxAuxData (
  genMetadata,
  genMetadata',
) where

import Cardano.Ledger.BaseTypes (
  StrictMaybe (..),
 )
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.TxAuxData (
  Metadatum (..),
  ShelleyTxAuxData (..),
 )
import Control.Exception (assert)
import qualified Data.ByteString.Char8 as BS (length, pack)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T (pack)
import qualified Data.Text.Encoding as T
import Data.Word (Word64)
import Test.Cardano.Ledger.Shelley.Constants (Constants (..))
import Test.QuickCheck (Gen)
import qualified Test.QuickCheck as QC

-- | Max size of generated Metadatum List and Map
collectionDatumMaxSize :: Int
collectionDatumMaxSize :: Int
collectionDatumMaxSize = Int
5

-- | Max size of generated Metadata map
metadataMaxSize :: Int
metadataMaxSize :: Int
metadataMaxSize = Int
3

-- | Generate ShelleyTxAuxData (and compute hash) with frequency 'frequencyTxWithMetadata'
genMetadata :: Era era => Constants -> Gen (StrictMaybe (ShelleyTxAuxData era))
genMetadata :: forall era.
Era era =>
Constants -> Gen (StrictMaybe (ShelleyTxAuxData era))
genMetadata (Constants {Int
frequencyTxWithMetadata :: Constants -> Int
frequencyTxWithMetadata :: Int
frequencyTxWithMetadata}) =
  [(Int, Gen (StrictMaybe (ShelleyTxAuxData era)))]
-> Gen (StrictMaybe (ShelleyTxAuxData era))
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
    [ (Int
frequencyTxWithMetadata, ShelleyTxAuxData era -> StrictMaybe (ShelleyTxAuxData era)
forall a. a -> StrictMaybe a
SJust (ShelleyTxAuxData era -> StrictMaybe (ShelleyTxAuxData era))
-> Gen (ShelleyTxAuxData era)
-> Gen (StrictMaybe (ShelleyTxAuxData era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (ShelleyTxAuxData era)
forall era. Era era => Gen (ShelleyTxAuxData era)
genMetadata')
    , (Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
frequencyTxWithMetadata, StrictMaybe (ShelleyTxAuxData era)
-> Gen (StrictMaybe (ShelleyTxAuxData era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StrictMaybe (ShelleyTxAuxData era)
forall a. StrictMaybe a
SNothing)
    ]

-- | Generate Metadata (and compute hash) of size up to 'metadataMaxSize'
genMetadata' :: Era era => Gen (ShelleyTxAuxData era)
genMetadata' :: forall era. Era era => Gen (ShelleyTxAuxData era)
genMetadata' = do
  n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
1, Int
metadataMaxSize)
  ShelleyTxAuxData . Map.fromList
    <$> QC.vectorOf n genMetadatum

-- | Generate one of the Metadatum
genMetadatum :: Gen (Word64, Metadatum)
genMetadatum :: Gen (Word64, Metadatum)
genMetadatum = do
  (,)
    (Word64 -> Metadatum -> (Word64, Metadatum))
-> Gen Word64 -> Gen (Metadatum -> (Word64, Metadatum))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
QC.arbitrary
    Gen (Metadatum -> (Word64, Metadatum))
-> Gen Metadatum -> Gen (Word64, Metadatum)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( [Gen Metadatum] -> Gen Metadatum
forall a. HasCallStack => [Gen a] -> Gen a
QC.oneof
            [ Gen Metadatum
genDatumInt
            , Gen Metadatum
genDatumString
            , Gen Metadatum
genDatumBytestring
            , Gen Metadatum
genMetadatumList
            , Gen Metadatum
genMetadatumMap
            ]
        )

genDatumInt :: Gen Metadatum
genDatumInt :: Gen Metadatum
genDatumInt =
  Integer -> Metadatum
I
    (Integer -> Metadatum) -> Gen Integer -> Gen Metadatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Gen Integer)] -> Gen Integer
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
      [ (Int
8, (Integer, Integer) -> Gen Integer
forall a. Random a => (a, a) -> Gen a
QC.choose (Integer
minVal, Integer
maxVal))
      , (Int
1, Integer -> Gen Integer
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
minVal)
      , (Int
1, Integer -> Gen Integer
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
maxVal)
      ]
  where
    minVal, maxVal :: Integer
    minVal :: Integer
minVal = -Integer
maxVal
    maxVal :: Integer
maxVal = Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
forall a. Bounded a => a
maxBound :: Word64)

genDatumString :: Gen Metadatum
genDatumString :: Gen Metadatum
genDatumString =
  (Int -> Gen Metadatum) -> Gen Metadatum
forall a. (Int -> Gen a) -> Gen a
QC.sized ((Int -> Gen Metadatum) -> Gen Metadatum)
-> (Int -> Gen Metadatum) -> Gen Metadatum
forall a b. (a -> b) -> a -> b
$ \Int
sz -> do
    n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
sz Int
64)
    cs <- genUtf8StringOfSize n
    let s = [Char] -> Text
T.pack [Char]
cs
    assert (BS.length (T.encodeUtf8 s) == n) $
      return (S s)

-- | Produce an arbitrary Unicode string such that it's UTF8 encoding size in
-- bytes is exactly the given length.
genUtf8StringOfSize :: Int -> Gen [Char]
genUtf8StringOfSize :: Int -> Gen [Char]
genUtf8StringOfSize Int
0 = [Char] -> Gen [Char]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return []
genUtf8StringOfSize Int
n = do
  cz <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
1, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
n Int
4)
  c <- case cz of
    Int
1 -> (Char, Char) -> Gen Char
forall a. Random a => (a, a) -> Gen a
QC.choose (Char
'\x00000', Char
'\x00007f')
    Int
2 -> (Char, Char) -> Gen Char
forall a. Random a => (a, a) -> Gen a
QC.choose (Char
'\x00080', Char
'\x0007ff')
    Int
3 ->
      [Gen Char] -> Gen Char
forall a. HasCallStack => [Gen a] -> Gen a
QC.oneof
        [ (Char, Char) -> Gen Char
forall a. Random a => (a, a) -> Gen a
QC.choose (Char
'\x00800', Char
'\x00d7ff')
        , -- skipping UTF-16 surrogates d800--dfff
          (Char, Char) -> Gen Char
forall a. Random a => (a, a) -> Gen a
QC.choose (Char
'\x0e000', Char
'\x00ffff')
        ]
    Int
_ -> (Char, Char) -> Gen Char
forall a. Random a => (a, a) -> Gen a
QC.choose (Char
'\x10000', Char
'\x10ffff')
  cs <- genUtf8StringOfSize (n - cz)
  return (c : cs)

genDatumBytestring :: Gen Metadatum
genDatumBytestring :: Gen Metadatum
genDatumBytestring =
  (Int -> Gen Metadatum) -> Gen Metadatum
forall a. (Int -> Gen a) -> Gen a
QC.sized ((Int -> Gen Metadatum) -> Gen Metadatum)
-> (Int -> Gen Metadatum) -> Gen Metadatum
forall a b. (a -> b) -> a -> b
$ \Int
sz -> do
    n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
sz Int
64)
    B . BS.pack <$> QC.vectorOf n QC.arbitrary

-- | Generate a 'MD.List [Metadatum]'
--
-- Note: to limit generated metadata size, impact on transaction fees and
-- cost of hashing, we generate only lists of "simple" Datums, not lists
-- of list or map Datum.
genMetadatumList :: Gen Metadatum
genMetadatumList :: Gen Metadatum
genMetadatumList = [Metadatum] -> Metadatum
List ([Metadatum] -> Metadatum) -> Gen [Metadatum] -> Gen Metadatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Metadatum]
vectorOfMetadatumSimple

-- | Generate a 'MD.Map ('[(Metadatum, Metadatum)]')
genMetadatumMap :: Gen Metadatum
genMetadatumMap :: Gen Metadatum
genMetadatumMap =
  [(Metadatum, Metadatum)] -> Metadatum
Map ([(Metadatum, Metadatum)] -> Metadatum)
-> Gen [(Metadatum, Metadatum)] -> Gen Metadatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Metadatum] -> [Metadatum] -> [(Metadatum, Metadatum)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Metadatum] -> [Metadatum] -> [(Metadatum, Metadatum)])
-> Gen [Metadatum] -> Gen ([Metadatum] -> [(Metadatum, Metadatum)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Metadatum]
vectorOfMetadatumSimple Gen ([Metadatum] -> [(Metadatum, Metadatum)])
-> Gen [Metadatum] -> Gen [(Metadatum, Metadatum)]
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen [Metadatum]
vectorOfMetadatumSimple)

vectorOfMetadatumSimple :: Gen [Metadatum]
vectorOfMetadatumSimple :: Gen [Metadatum]
vectorOfMetadatumSimple = do
  n <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
QC.choose (Int
1, Int
collectionDatumMaxSize)
  QC.vectorOf
    n
    ( QC.oneof
        [ genDatumInt
        , genDatumString
        , genDatumBytestring
        ]
    )