{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Core.HuddleSpec where

import Cardano.Ledger.BaseTypes (getVersion)
import Cardano.Ledger.Core (ByronEra, eraProtVerHigh, eraProtVerLow)
import Cardano.Ledger.Huddle
import Cardano.Ledger.Huddle.Gen (
  CBORGen,
  CustomValidatorResult (..),
  MonadGen (..),
  RuleTerm (..),
  arbitrary,
  genArrayTerm,
  liftAntiGen,
  oneof,
  vectorOf,
  (|!),
 )
import Codec.CBOR.Cuddle.CDDL (Name (..))
import Codec.CBOR.Cuddle.Huddle as H
import Codec.CBOR.Term (Term (..))
import Data.Bits (Bits (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.MemPack (VarLen (..), packByteString)
import Data.Proxy (Proxy (..))
import qualified Data.Text as T
import Data.Word (Word16, Word32, Word64)
import GHC.TypeLits (KnownSymbol, Symbol)
import Text.Heredoc
import Prelude hiding ((/))

genByteString :: MonadGen m => Int -> m ByteString
genByteString :: forall (m :: * -> *). MonadGen m => Int -> m ByteString
genByteString Int
n = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> m [Word8] -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> m Word8 -> m [Word8]
forall (m :: * -> *) a. MonadGen m => Int -> m a -> m [a]
vectorOf Int
n m Word8
forall a (m :: * -> *). (MonadGen m, Arbitrary a) => m a
arbitrary

-- | Generator for plutus scripts that produces random bytestrings.
-- This avoids collisions when scripts appear in sets (tag 258).
plutusScriptGen :: MonadGen m => m RuleTerm
plutusScriptGen :: forall (m :: * -> *). MonadGen m => m RuleTerm
plutusScriptGen = Term -> RuleTerm
SingleTerm (Term -> RuleTerm)
-> (ByteString -> Term) -> ByteString -> RuleTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Term
TBytes (ByteString -> RuleTerm) -> m ByteString -> m RuleTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> m ByteString
forall (m :: * -> *). MonadGen m => Int -> m ByteString
genByteString (Int -> m ByteString) -> m Int -> m ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Int, Int) -> m Int
forall a. Random a => (a, a) -> m a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
8, Int
1024))

instance Era era => HuddleRule "hash28" era where
  huddleRuleNamed :: Proxy "hash28" -> Proxy era -> Rule
huddleRuleNamed Proxy "hash28"
pname Proxy era
_ = Proxy "hash28"
pname Proxy "hash28" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value ByteString
VBytes Value ByteString -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
28 :: Word64)

instance Era era => HuddleRule "hash32" era where
  huddleRuleNamed :: Proxy "hash32" -> Proxy era -> Rule
huddleRuleNamed Proxy "hash32"
pname Proxy era
_ = Proxy "hash32"
pname Proxy "hash32" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value ByteString
VBytes Value ByteString -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
32 :: Word64)

instance Era era => HuddleRule "max_word64" era where
  huddleRuleNamed :: Proxy "max_word64" -> Proxy era -> Rule
huddleRuleNamed Proxy "max_word64"
pname Proxy era
_ = Proxy "max_word64"
pname Proxy "max_word64" -> Integer -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= (Integer
18446744073709551615 :: Integer)

instance Era era => HuddleRule "positive_int" era where
  huddleRuleNamed :: Proxy "positive_int" -> Proxy era -> Rule
huddleRuleNamed Proxy "positive_int"
pname Proxy era
p = Proxy "positive_int"
pname Proxy "positive_int" -> Ranged -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= (Integer
1 :: Integer) Integer -> Rule -> Ranged
forall a b. (IsRangeBound a, IsRangeBound b) => a -> b -> Ranged
... forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"max_word64" Proxy era
p

instance Era era => HuddleRule "max_word32" era where
  huddleRuleNamed :: Proxy "max_word32" -> Proxy era -> Rule
huddleRuleNamed Proxy "max_word32"
pname Proxy era
_ = Proxy "max_word32"
pname Proxy "max_word32" -> Integer -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= (Integer
4294967295 :: Integer)

instance Era era => HuddleRule "positive_word32" era where
  huddleRuleNamed :: Proxy "positive_word32" -> Proxy era -> Rule
huddleRuleNamed Proxy "positive_word32"
pname Proxy era
p = Proxy "positive_word32"
pname Proxy "positive_word32" -> Ranged -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= (Integer
1 :: Integer) Integer -> Rule -> Ranged
forall a b. (IsRangeBound a, IsRangeBound b) => a -> b -> Ranged
... forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"max_word32" Proxy era
p

instance Era era => HuddleRule "unit_interval" era where
  huddleRuleNamed :: Proxy "unit_interval" -> Proxy era -> Rule
huddleRuleNamed Proxy "unit_interval"
pname Proxy era
_ =
    Comment -> Rule -> Rule
forall a. HasComment a => Comment -> a -> a
comment
      Comment
[str| A unit interval is a number in the range between 0 and 1, which
          | means there are two extra constraints:
          |   1. numerator <= denominator
          |   2. denominator > 0
          |
          | The relation between numerator and denominator can be
          | expressed in CDDL, but we have a limitation currently
          | (see: https://github.com/input-output-hk/cuddle/issues/30).
          |]
      (Rule -> Rule) -> (Rule -> Rule) -> Rule -> Rule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CBORGen RuleTerm -> Rule -> Rule
forall a. HasGenerator a => CBORGen RuleTerm -> a -> a
withCBORGen CBORGen RuleTerm
generator
      (Rule -> Rule) -> Rule -> Rule
forall a b. (a -> b) -> a -> b
$ Proxy "unit_interval"
pname Proxy "unit_interval" -> Tagged ArrayChoice -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Word64 -> ArrayChoice -> Tagged ArrayChoice
forall a. Word64 -> a -> Tagged a
tag Word64
30 (ArrayChoice -> ArrayChoice
arr [Value Int -> ArrayEntry
forall a e. (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a Value Int
VUInt, Value Int -> ArrayEntry
forall a e. (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a Value Int
VUInt])
    where
      generator :: CBORGen RuleTerm
generator = do
        let genUnitInterval64 :: b -> b -> m (b, b)
genUnitInterval64 b
l b
u = do
              d <- (b, b) -> m b
forall a. Random a => (a, a) -> m a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (b -> b -> b
forall a. Ord a => a -> a -> a
max b
1 b
l, b
u)
              n <- choose (l, d)
              pure (n, d)
            max64 :: Integer
max64 = Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound @Word64)
        (n, d) <-
          [CBORGen (Integer, Integer)] -> CBORGen (Integer, Integer)
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
oneof
            [ Integer -> Integer -> CBORGen (Integer, Integer)
forall {m :: * -> *} {b}.
(MonadGen m, Random b, Ord b, Num b) =>
b -> b -> m (b, b)
genUnitInterval64 Integer
0 Integer
max64
            , Integer -> Integer -> CBORGen (Integer, Integer)
forall {m :: * -> *} {b}.
(MonadGen m, Random b, Ord b, Num b) =>
b -> b -> m (b, b)
genUnitInterval64 Integer
0 Integer
1000
            , Integer -> Integer -> CBORGen (Integer, Integer)
forall {m :: * -> *} {b}.
(MonadGen m, Random b, Ord b, Num b) =>
b -> b -> m (b, b)
genUnitInterval64 (Integer
max64 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1000) Integer
max64
            ]
        SingleTerm . TTagged 30
          <$> genArrayTerm [TInteger $ toInteger n, TInteger $ toInteger d]

instance Era era => HuddleRule "nonnegative_interval" era where
  huddleRuleNamed :: Proxy "nonnegative_interval" -> Proxy era -> Rule
huddleRuleNamed Proxy "nonnegative_interval"
pname Proxy era
p =
    Proxy "nonnegative_interval"
pname Proxy "nonnegative_interval" -> Tagged ArrayChoice -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Word64 -> ArrayChoice -> Tagged ArrayChoice
forall a. Word64 -> a -> Tagged a
tag Word64
30 (ArrayChoice -> ArrayChoice
arr [Value Int -> ArrayEntry
forall a e. (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a Value Int
VUInt, Rule -> ArrayEntry
forall a e. (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a (forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"positive_int" Proxy era
p)])

distinct :: IsSizeable s => Value s -> HuddleItem
distinct :: forall s. IsSizeable s => Value s -> HuddleItem
distinct Value s
x =
  Rule -> HuddleItem
HIRule
    (Rule -> HuddleItem) -> Rule -> HuddleItem
forall a b. (a -> b) -> a -> b
$ Comment -> Rule -> Rule
forall a. HasComment a => Comment -> a -> a
comment
      Comment
[str| A type for distinct values.
          | The type parameter must support .size, for example: bytes or uint
          |]
    (Rule -> Rule) -> Rule -> Rule
forall a b. (a -> b) -> a -> b
$ Name
"distinct_"
      Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Text -> Name
Name (Value s -> Text
forall s. Value s -> Text
show' Value s
x)
        Name -> Choice Type2 -> Rule
forall a. IsType0 a => Name -> a -> Rule
=:= (Value s
x Value s -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
8 :: Word64))
        Constrained -> Constrained -> Choice Type2
forall a c b.
(IsChoosable a c, IsChoosable b c) =>
a -> b -> Choice c
/ (Value s
x Value s -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
16 :: Word64))
        Choice Type2 -> Constrained -> Choice Type2
forall a c b.
(IsChoosable a c, IsChoosable b c) =>
a -> b -> Choice c
/ (Value s
x Value s -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
20 :: Word64))
        Choice Type2 -> Constrained -> Choice Type2
forall a c b.
(IsChoosable a c, IsChoosable b c) =>
a -> b -> Choice c
/ (Value s
x Value s -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
24 :: Word64))
        Choice Type2 -> Constrained -> Choice Type2
forall a c b.
(IsChoosable a c, IsChoosable b c) =>
a -> b -> Choice c
/ (Value s
x Value s -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
30 :: Word64))
        Choice Type2 -> Constrained -> Choice Type2
forall a c b.
(IsChoosable a c, IsChoosable b c) =>
a -> b -> Choice c
/ (Value s
x Value s -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
32 :: Word64))
  where
    show' :: Value s -> T.Text
    show' :: forall s. Value s -> Text
show' = \case
      Value s
VBytes -> String -> Text
T.pack String
"bytes"
      Value s
VUInt -> String -> Text
T.pack String
"uint"
      Value s
_ -> String -> Text
forall a. HasCallStack => String -> a
error String
"Unsupported Value for `distinct`"

instance Era era => HuddleRule "nonce" era where
  huddleRuleNamed :: Proxy "nonce" -> Proxy era -> Rule
huddleRuleNamed Proxy "nonce"
pname Proxy era
p = Proxy "nonce"
pname Proxy "nonce" -> Choice ArrayChoice -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= ArrayChoice -> ArrayChoice
arr [Item ArrayChoice
ArrayEntry
0] ArrayChoice -> ArrayChoice -> Choice ArrayChoice
forall a c b.
(IsChoosable a c, IsChoosable b c) =>
a -> b -> Choice c
/ ArrayChoice -> ArrayChoice
arr [Item ArrayChoice
ArrayEntry
1, Rule -> ArrayEntry
forall a e. (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a (forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"hash32" Proxy era
p)]

instance Era era => HuddleRule "epoch" era where
  huddleRuleNamed :: Proxy "epoch" -> Proxy era -> Rule
huddleRuleNamed Proxy "epoch"
pname Proxy era
_ = Proxy "epoch"
pname Proxy "epoch" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value Int
VUInt Value Int -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
8 :: Word64)

instance Era era => HuddleRule "epoch_interval" era where
  huddleRuleNamed :: Proxy "epoch_interval" -> Proxy era -> Rule
huddleRuleNamed Proxy "epoch_interval"
pname Proxy era
_ = Proxy "epoch_interval"
pname Proxy "epoch_interval" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value Int
VUInt Value Int -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
4 :: Word64)

instance Era era => HuddleRule "slot" era where
  huddleRuleNamed :: Proxy "slot" -> Proxy era -> Rule
huddleRuleNamed Proxy "slot"
pname Proxy era
_ = Proxy "slot"
pname Proxy "slot" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value Int
VUInt Value Int -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
8 :: Word64)

instance Era era => HuddleRule "block_number" era where
  huddleRuleNamed :: Proxy "block_number" -> Proxy era -> Rule
huddleRuleNamed Proxy "block_number"
pname Proxy era
_ = Proxy "block_number"
pname Proxy "block_number" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value Int
VUInt Value Int -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
8 :: Word64)

instance Era era => HuddleRule "addr_keyhash" era where
  huddleRuleNamed :: Proxy "addr_keyhash" -> Proxy era -> Rule
huddleRuleNamed Proxy "addr_keyhash"
pname Proxy era
p = Proxy "addr_keyhash"
pname Proxy "addr_keyhash" -> Rule -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"hash28" Proxy era
p

instance Era era => HuddleRule "pool_keyhash" era where
  huddleRuleNamed :: Proxy "pool_keyhash" -> Proxy era -> Rule
huddleRuleNamed Proxy "pool_keyhash"
pname Proxy era
p = Proxy "pool_keyhash"
pname Proxy "pool_keyhash" -> Rule -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"hash28" Proxy era
p

instance Era era => HuddleRule "vrf_keyhash" era where
  huddleRuleNamed :: Proxy "vrf_keyhash" -> Proxy era -> Rule
huddleRuleNamed Proxy "vrf_keyhash"
pname Proxy era
p = Proxy "vrf_keyhash"
pname Proxy "vrf_keyhash" -> Rule -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"hash32" Proxy era
p

instance Era era => HuddleRule "vkey" era where
  huddleRuleNamed :: Proxy "vkey" -> Proxy era -> Rule
huddleRuleNamed Proxy "vkey"
pname Proxy era
_ = Proxy "vkey"
pname Proxy "vkey" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value ByteString
VBytes Value ByteString -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
32 :: Word64)

instance Era era => HuddleRule "vrf_vkey" era where
  huddleRuleNamed :: Proxy "vrf_vkey" -> Proxy era -> Rule
huddleRuleNamed Proxy "vrf_vkey"
pname Proxy era
_ = Proxy "vrf_vkey"
pname Proxy "vrf_vkey" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value ByteString
VBytes Value ByteString -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
32 :: Word64)

instance Era era => HuddleRule "vrf_cert" era where
  huddleRuleNamed :: Proxy "vrf_cert" -> Proxy era -> Rule
huddleRuleNamed Proxy "vrf_cert"
pname Proxy era
_ = Proxy "vrf_cert"
pname Proxy "vrf_cert" -> ArrayChoice -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= ArrayChoice -> ArrayChoice
arr [Value ByteString -> ArrayEntry
forall a e. (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a Value ByteString
VBytes, Constrained -> ArrayEntry
forall a e. (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a (Value ByteString
VBytes Value ByteString -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
80 :: Word64))]

instance Era era => HuddleRule "kes_vkey" era where
  huddleRuleNamed :: Proxy "kes_vkey" -> Proxy era -> Rule
huddleRuleNamed Proxy "kes_vkey"
pname Proxy era
_ = Proxy "kes_vkey"
pname Proxy "kes_vkey" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value ByteString
VBytes Value ByteString -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
32 :: Word64)

instance Era era => HuddleRule "kes_signature" era where
  huddleRuleNamed :: Proxy "kes_signature" -> Proxy era -> Rule
huddleRuleNamed Proxy "kes_signature"
pname Proxy era
_ = Proxy "kes_signature"
pname Proxy "kes_signature" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value ByteString
VBytes Value ByteString -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
448 :: Word64)

instance Era era => HuddleRule "signkey_kes" era where
  huddleRuleNamed :: Proxy "signkey_kes" -> Proxy era -> Rule
huddleRuleNamed Proxy "signkey_kes"
pname Proxy era
_ = Proxy "signkey_kes"
pname Proxy "signkey_kes" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value ByteString
VBytes Value ByteString -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
64 :: Word64)

instance Era era => HuddleRule "sequence_number" era where
  huddleRuleNamed :: Proxy "sequence_number" -> Proxy era -> Rule
huddleRuleNamed Proxy "sequence_number"
pname Proxy era
_ = Proxy "sequence_number"
pname Proxy "sequence_number" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value Int
VUInt Value Int -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
8 :: Word64)

instance Era era => HuddleRule "kes_period" era where
  huddleRuleNamed :: Proxy "kes_period" -> Proxy era -> Rule
huddleRuleNamed Proxy "kes_period"
pname Proxy era
_ = Proxy "kes_period"
pname Proxy "kes_period" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value Int
VUInt Value Int -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
8 :: Word64)

instance Era era => HuddleRule "signature" era where
  huddleRuleNamed :: Proxy "signature" -> Proxy era -> Rule
huddleRuleNamed Proxy "signature"
pname Proxy era
_ = Proxy "signature"
pname Proxy "signature" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value ByteString
VBytes Value ByteString -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
64 :: Word64)

instance Era era => HuddleRule "coin" era where
  huddleRuleNamed :: Proxy "coin" -> Proxy era -> Rule
huddleRuleNamed Proxy "coin"
pname Proxy era
_ = Proxy "coin"
pname Proxy "coin" -> Value Int -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value Int
VUInt

instance Era era => HuddleRule "positive_coin" era where
  huddleRuleNamed :: Proxy "positive_coin" -> Proxy era -> Rule
huddleRuleNamed Proxy "positive_coin"
pname Proxy era
p = Proxy "positive_coin"
pname Proxy "positive_coin" -> Ranged -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= (Integer
1 :: Integer) Integer -> Rule -> Ranged
forall a b. (IsRangeBound a, IsRangeBound b) => a -> b -> Ranged
... forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"max_word64" Proxy era
p

genHash28 :: MonadGen m => m ByteString
genHash28 :: forall (m :: * -> *). MonadGen m => m ByteString
genHash28 = Int -> m ByteString
forall (m :: * -> *). MonadGen m => Int -> m ByteString
genByteString Int
28

instance Era era => HuddleRule "address" era where
  huddleRuleNamed :: Proxy "address" -> Proxy era -> Rule
huddleRuleNamed Proxy "address"
pname Proxy era
_ =
    Comment -> Rule -> Rule
forall a. HasComment a => Comment -> a -> a
comment
      Comment
[str| address format:
          |   [ 8 bit header | payload ];
          |
          | shelley payment addresses:
          |      bit 7: 0
          |      bit 6: base/other
          |      bit 5: pointer/enterprise [for base: stake cred is keyhash/scripthash]
          |      bit 4: payment cred is keyhash/scripthash
          |   bits 3-0: network id
          |
          | reward addresses:
          |   bits 7-5: 111
          |      bit 4: credential is keyhash/scripthash
          |   bits 3-0: network id
          |
          | byron addresses:
          |   bits 7-4: 1000
          |
          |      0000: base address: keyhash28,keyhash28
          |      0001: base address: scripthash28,keyhash28
          |      0010: base address: keyhash28,scripthash28
          |      0011: base address: scripthash28,scripthash28
          |      0100: pointer address: keyhash28, 3 variable length uint
          |      0101: pointer address: scripthash28, 3 variable length uint
          |      0110: enterprise address: keyhash28
          |      0111: enterprise address: scripthash28
          |      1000: byron address
          |      1110: account address: keyhash28
          |      1111: account address: scripthash28
          | 1001-1101: future formats
          |]
      (Rule -> Rule) -> (Rule -> Rule) -> Rule -> Rule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CBORGen RuleTerm -> Rule -> Rule
forall a. HasGenerator a => CBORGen RuleTerm -> a -> a
withCBORGen CBORGen RuleTerm
generator
      (Rule -> Rule) -> Rule -> Rule
forall a b. (a -> b) -> a -> b
$ Proxy "address"
pname Proxy "address" -> Value ByteString -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value ByteString
VBytes
    where
      generator :: CBORGen RuleTerm
generator = do
        stakeRef <- (Word8, Word8) -> CBORGen Word8
forall a. Random a => (a, a) -> CBORGen a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Word8
0, Word8
0b11)
        let
          stakeRefMask = Word8
stakeRef Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
5 -- 0b0xx00000
          mkMask p
mask Bool
isMask = if Bool
isMask then p
mask else p
0
        isPaymentScriptMask <- mkMask 0b00010000 <$> arbitrary
        isMainnetMask <- mkMask 0b00000001 <$> arbitrary
        let
          header = Word8
stakeRefMask Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
isPaymentScriptMask Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
isMainnetMask
          genVar32 = Word32 -> VarLen Word32
forall a. a -> VarLen a
VarLen (Word32 -> VarLen Word32)
-> CBORGen Word32 -> CBORGen (VarLen Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (MonadGen m, Arbitrary a) => m a
arbitrary @Word32
          genVar16 = Word16 -> VarLen Word16
forall a. a -> VarLen a
VarLen (Word16 -> VarLen Word16)
-> CBORGen Word16 -> CBORGen (VarLen Word16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (MonadGen m, Arbitrary a) => m a
arbitrary @Word16
        stakeCred <- case stakeRef of
          Word8
0b00 -> CBORGen ByteString
forall (m :: * -> *). MonadGen m => m ByteString
genHash28 -- staking payment hash
          Word8
0b01 -> CBORGen ByteString
forall (m :: * -> *). MonadGen m => m ByteString
genHash28 -- staking script hash
          Word8
0b10 -> do
            -- Ptr
            slotNo <- CBORGen (VarLen Word32)
genVar32
            txIx <- genVar16
            certIx <- genVar16
            pure $ packByteString slotNo <> packByteString txIx <> packByteString certIx
          Word8
_ -> ByteString -> CBORGen ByteString
forall a. a -> CBORGen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
forall a. Monoid a => a
mempty
        paymentCred <- genHash28
        -- TODO use genBytesTerm once indefinite bytestring decoding has been fixed
        let bytesTerm = ByteString -> Term
TBytes (ByteString -> Term)
-> (ByteString -> ByteString) -> ByteString -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> ByteString
BS.cons Word8
header (ByteString -> Term) -> ByteString -> Term
forall a b. (a -> b) -> a -> b
$ ByteString
paymentCred ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
stakeCred
        pure $ SingleTerm bytesTerm

instance Era era => HuddleRule "reward_account" era where
  huddleRuleNamed :: Proxy "reward_account" -> Proxy era -> Rule
huddleRuleNamed Proxy "reward_account"
pname Proxy era
_ = CBORGen RuleTerm -> Rule -> Rule
forall a. HasGenerator a => CBORGen RuleTerm -> a -> a
withCBORGen CBORGen RuleTerm
generator (Rule -> Rule) -> Rule -> Rule
forall a b. (a -> b) -> a -> b
$ Proxy "reward_account"
pname Proxy "reward_account" -> Value ByteString -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value ByteString
VBytes
    where
      generator :: CBORGen RuleTerm
generator = do
        isMainnet <- CBORGen Bool
forall a (m :: * -> *). (MonadGen m, Arbitrary a) => m a
arbitrary
        isScript <- arbitrary
        let
          mainnetMask | Bool
isMainnet = Word8
0b00000001 | Bool
otherwise = Word8
0x00
          scriptMask | Bool
isScript = Word8
0b00010000 | Bool
otherwise = Word8
0x00
          header = Word8
0b11100000 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
mainnetMask Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
scriptMask
        payload <- genHash28
        let term = ByteString -> Term
TBytes (ByteString -> Term) -> ByteString -> Term
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> ByteString
BS.cons Word8
header ByteString
payload
        pure $ SingleTerm term

instance Era era => HuddleRule "transaction_index" era where
  huddleRuleNamed :: Proxy "transaction_index" -> Proxy era -> Rule
huddleRuleNamed Proxy "transaction_index"
pname Proxy era
_ = Proxy "transaction_index"
pname Proxy "transaction_index" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value Int
VUInt Value Int -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
2 :: Word64)

instance Era era => HuddleRule "metadatum_label" era where
  huddleRuleNamed :: Proxy "metadatum_label" -> Proxy era -> Rule
huddleRuleNamed Proxy "metadatum_label"
pname Proxy era
_ = Proxy "metadatum_label"
pname Proxy "metadatum_label" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value Int
VUInt Value Int -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Word64
8 :: Word64)

instance (Era era, HuddleRule "metadatum" era) => HuddleRule "metadata" era where
  huddleRuleNamed :: Proxy "metadata" -> Proxy era -> Rule
huddleRuleNamed Proxy "metadata"
pname Proxy era
p =
    Proxy "metadata"
pname
      Proxy "metadata" -> MapChoice -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= MapChoice -> MapChoice
mp
        [ Word64
0
            Word64 -> MapEntry -> MapEntry
forall a. CanQuantify a => Word64 -> a -> a
<+ Rule -> Key
forall r. IsType0 r => r -> Key
asKey (forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"metadatum_label" Proxy era
p)
            Key -> Rule -> MapEntry
forall a me. (IsType0 a, IsEntryLike me) => Key -> a -> me
==> forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"metadatum" Proxy era
p
        ]

instance Era era => HuddleRule "auxiliary_data_hash" era where
  huddleRuleNamed :: Proxy "auxiliary_data_hash" -> Proxy era -> Rule
huddleRuleNamed Proxy "auxiliary_data_hash"
pname Proxy era
p = Proxy "auxiliary_data_hash"
pname Proxy "auxiliary_data_hash" -> Rule -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"hash32" Proxy era
p

instance Era era => HuddleRule "script_hash" era where
  huddleRuleNamed :: Proxy "script_hash" -> Proxy era -> Rule
huddleRuleNamed Proxy "script_hash"
pname Proxy era
p =
    Comment -> Rule -> Rule
forall a. HasComment a => Comment -> a -> a
comment
      Comment
[str| To compute a script hash, note that you must prepend
          | a tag to the bytes of the script before hashing.
          | The tag is determined by the language.
          | The tags are:
          |   "\x00" for multisig/native scripts
          |   "\x01" for Plutus V1 scripts
          |   "\x02" for Plutus V2 scripts
          |   "\x03" for Plutus V3 scripts
          |   "\x04" for Plutus V4 scripts
          |]
      (Rule -> Rule) -> Rule -> Rule
forall a b. (a -> b) -> a -> b
$ Proxy "script_hash"
pname
        Proxy "script_hash" -> Rule -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"hash28" Proxy era
p

instance Era era => HuddleRule "credential" era where
  huddleRuleNamed :: Proxy "credential" -> Proxy era -> Rule
huddleRuleNamed Proxy "credential"
pname Proxy era
p =
    Proxy "credential"
pname
      Proxy "credential" -> Choice ArrayChoice -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= ArrayChoice -> ArrayChoice
arr [Item ArrayChoice
ArrayEntry
0, Rule -> ArrayEntry
forall a e. (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a (forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"addr_keyhash" Proxy era
p)]
      ArrayChoice -> ArrayChoice -> Choice ArrayChoice
forall a c b.
(IsChoosable a c, IsChoosable b c) =>
a -> b -> Choice c
/ ArrayChoice -> ArrayChoice
arr [Item ArrayChoice
ArrayEntry
1, Rule -> ArrayEntry
forall a e. (IsType0 a, IsGroupOrArrayEntry e) => a -> e
a (forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"script_hash" Proxy era
p)]

instance Era era => HuddleRule "stake_credential" era where
  huddleRuleNamed :: Proxy "stake_credential" -> Proxy era -> Rule
huddleRuleNamed Proxy "stake_credential"
pname Proxy era
p = Proxy "stake_credential"
pname Proxy "stake_credential" -> Rule -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= forall (name :: Symbol) era.
HuddleRule name era =>
Proxy era -> Rule
huddleRule @"credential" Proxy era
p

instance Era era => HuddleRule "port" era where
  huddleRuleNamed :: Proxy "port" -> Proxy era -> Rule
huddleRuleNamed Proxy "port"
pname Proxy era
_ = Proxy "port"
pname Proxy "port" -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value Int
VUInt Value Int -> Word64 -> Constrained
forall a c.
(IsComparable a, IsConstrainable c a) =>
c -> Word64 -> Constrained
`le` Word64
65535

ipGen :: Int -> CBORGen RuleTerm
ipGen :: Int -> CBORGen RuleTerm
ipGen Int
n = do
  l <- AntiGen Int -> CBORGen Int
forall a. AntiGen a -> CBORGen a
liftAntiGen (AntiGen Int -> CBORGen Int) -> AntiGen Int -> CBORGen Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
n, Int
1024) Gen Int -> Gen Int -> AntiGen Int
forall a. Gen a -> Gen a -> AntiGen a
|! (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
0, Int -> Int
forall a. Enum a => a -> a
pred Int
n)
  bs <- genByteString l
  -- TODO Also generate with TBytesI
  pure . SingleTerm $ TBytes bs

ipValidator :: Int -> Term -> CustomValidatorResult
ipValidator :: Int -> Term -> CustomValidatorResult
ipValidator Int
n = \case
  TBytes ByteString
bs | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n -> CustomValidatorResult
CustomValidatorSuccess
  TBytesI ByteString
bs | ByteString -> Int64
LBS.length ByteString
bs Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n -> CustomValidatorResult
CustomValidatorSuccess
  Term
_ -> Text -> CustomValidatorResult
CustomValidatorFailure (Text -> CustomValidatorResult) -> Text -> CustomValidatorResult
forall a b. (a -> b) -> a -> b
$ Text
"Expected bytes with length >=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)

ipRule ::
  forall era (r :: Symbol).
  KnownSymbol r => Int -> Proxy r -> Proxy era -> Rule
ipRule :: forall era (r :: Symbol).
KnownSymbol r =>
Int -> Proxy r -> Proxy era -> Rule
ipRule Int
n Proxy r
pname Proxy era
_ = Proxy r
pname Proxy r -> Constrained -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= Value ByteString
VBytes Value ByteString -> Word64 -> Constrained
forall c a s.
(IsSizeable a, IsSize s, IsConstrainable c a) =>
c -> s -> Constrained
`H.sized` (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n :: Word64)

instance Era era => HuddleRule "ipv4" era where
  huddleRuleNamed :: Proxy "ipv4" -> Proxy era -> Rule
huddleRuleNamed = Int -> Proxy "ipv4" -> Proxy era -> Rule
forall era (r :: Symbol).
KnownSymbol r =>
Int -> Proxy r -> Proxy era -> Rule
ipRule Int
4

instance Era era => HuddleRule "ipv6" era where
  huddleRuleNamed :: Proxy "ipv6" -> Proxy era -> Rule
huddleRuleNamed = Int -> Proxy "ipv6" -> Proxy era -> Rule
forall era (r :: Symbol).
KnownSymbol r =>
Int -> Proxy r -> Proxy era -> Rule
ipRule Int
16

majorProtocolVersionRule ::
  forall era. Era era => Proxy "major_protocol_version" -> Proxy era -> Rule
majorProtocolVersionRule :: forall era.
Era era =>
Proxy "major_protocol_version" -> Proxy era -> Rule
majorProtocolVersionRule Proxy "major_protocol_version"
pname Proxy era
_ =
  Proxy "major_protocol_version"
pname
    Proxy "major_protocol_version" -> Ranged -> Rule
forall (name :: Symbol) t.
(KnownSymbol name, IsType0 t) =>
Proxy name -> t -> Rule
=.= forall i. Integral i => Version -> i
getVersion @Integer (forall era. Era era => Version
eraProtVerLow @ByronEra)
    Integer -> Integer -> Ranged
forall a b. (IsRangeBound a, IsRangeBound b) => a -> b -> Ranged
... Integer -> Integer
forall a. Enum a => a -> a
succ (forall i. Integral i => Version -> i
getVersion @Integer (forall era. Era era => Version
eraProtVerHigh @era))