{-# 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}) =
  forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
    [ (Int
frequencyTxWithMetadata, forall a. a -> StrictMaybe a
SJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. Era era => Gen (ShelleyTxAuxData era)
genMetadata')
    , (Int
100 forall a. Num a => a -> a -> a
- Int
frequencyTxWithMetadata, forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
  Int
n <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
1, Int
metadataMaxSize)
  forall era. Era era => Map Word64 Metadatum -> ShelleyTxAuxData era
ShelleyTxAuxData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> Gen a -> Gen [a]
QC.vectorOf Int
n Gen (Word64, Metadatum)
genMetadatum

-- | Generate one of the Metadatum
genMetadatum :: Gen (Word64, Metadatum)
genMetadatum :: Gen (Word64, Metadatum)
genMetadatum = do
  (,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
QC.arbitrary
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( 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
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasCallStack => [(Int, Gen a)] -> Gen a
QC.frequency
      [ (Int
8, forall a. Random a => (a, a) -> Gen a
QC.choose (Integer
minVal, Integer
maxVal))
      , (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
minVal)
      , (Int
1, forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
maxVal)
      ]
  where
    minVal, maxVal :: Integer
    minVal :: Integer
minVal = -Integer
maxVal
    maxVal :: Integer
maxVal = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word64)

genDatumString :: Gen Metadatum
genDatumString :: Gen Metadatum
genDatumString =
  forall a. (Int -> Gen a) -> Gen a
QC.sized forall a b. (a -> b) -> a -> b
$ \Int
sz -> do
    Int
n <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, forall a. Ord a => a -> a -> a
min Int
sz Int
64)
    [Char]
cs <- Int -> Gen [Char]
genUtf8StringOfSize Int
n
    let s :: Text
s = [Char] -> Text
T.pack [Char]
cs
    forall a. HasCallStack => Bool -> a -> a
assert (ByteString -> Int
BS.length (Text -> ByteString
T.encodeUtf8 Text
s) forall a. Eq a => a -> a -> Bool
== Int
n) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Metadatum
S Text
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 = forall (m :: * -> *) a. Monad m => a -> m a
return []
genUtf8StringOfSize Int
n = do
  Int
cz <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
1, forall a. Ord a => a -> a -> a
min Int
n Int
4)
  Char
c <- case Int
cz of
    Int
1 -> forall a. Random a => (a, a) -> Gen a
QC.choose (Char
'\x00000', Char
'\x00007f')
    Int
2 -> forall a. Random a => (a, a) -> Gen a
QC.choose (Char
'\x00080', Char
'\x0007ff')
    Int
3 ->
      forall a. HasCallStack => [Gen a] -> Gen a
QC.oneof
        [ forall a. Random a => (a, a) -> Gen a
QC.choose (Char
'\x00800', Char
'\x00d7ff')
        , -- skipping UTF-16 surrogates d800--dfff
          forall a. Random a => (a, a) -> Gen a
QC.choose (Char
'\x0e000', Char
'\x00ffff')
        ]
    Int
_ -> forall a. Random a => (a, a) -> Gen a
QC.choose (Char
'\x10000', Char
'\x10ffff')
  [Char]
cs <- Int -> Gen [Char]
genUtf8StringOfSize (Int
n forall a. Num a => a -> a -> a
- Int
cz)
  forall (m :: * -> *) a. Monad m => a -> m a
return (Char
c forall a. a -> [a] -> [a]
: [Char]
cs)

genDatumBytestring :: Gen Metadatum
genDatumBytestring :: Gen Metadatum
genDatumBytestring =
  forall a. (Int -> Gen a) -> Gen a
QC.sized forall a b. (a -> b) -> a -> b
$ \Int
sz -> do
    Int
n <- forall a. Random a => (a, a) -> Gen a
QC.choose (Int
0, forall a. Ord a => a -> a -> a
min Int
sz Int
64)
    ByteString -> Metadatum
B forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
BS.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Int -> Gen a -> Gen [a]
QC.vectorOf Int
n forall a. Arbitrary a => Gen a
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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a b. [a] -> [b] -> [(a, b)]
zip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [Metadatum]
vectorOfMetadatumSimple forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen [Metadatum]
vectorOfMetadatumSimple)

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