{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Cardano.Ledger.AddressSpec (spec) where

import qualified Cardano.Chain.Common as Byron
import qualified Cardano.Crypto.Hash.Class as Hash
import Cardano.Ledger.Address
import Cardano.Ledger.Binary (Version, byronProtVer, decodeFull', natVersion, serialize')
import Cardano.Ledger.Credential
import Cardano.Ledger.Crypto (Crypto (ADDRHASH), StandardCrypto)
import Cardano.Ledger.Keys (
  BootstrapWitness (..),
  bootstrapWitKeyHash,
  coerceKeyRole,
  unpackByronVKey,
 )
import Control.Monad.Trans.Fail.String (errorFail)
import qualified Data.Binary.Put as B
import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Short as SBS
import Data.Either
import Data.Maybe (isNothing)
import Data.Proxy
import Data.Word
import Test.Cardano.Ledger.Binary.RoundTrip (
  cborTrip,
  roundTripCborSpec,
  roundTripRangeExpectation,
 )
import Test.Cardano.Ledger.Common hiding ((.&.))
import Test.Cardano.Ledger.Core.Address
import Test.Cardano.Ledger.Core.Arbitrary (genAddrBadPtr, genCompactAddrBadPtr)
import Test.Cardano.Ledger.Core.KeyPair (genByronVKeyAddr)

spec :: Spec
spec :: Spec
spec =
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Address" forall a b. (a -> b) -> a -> b
$ do
    Spec
roundTripAddressSpec
    forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"rebuild the 'addr root' using a bootstrap witness" forall a b. (a -> b) -> a -> b
$ do
      (VerificationKey
byronVKey, Address
byronAddr) <- Gen (VerificationKey, Address)
genByronVKeyAddr
      SignedDSIGN Ed25519DSIGN (Hash Blake2b_256 EraIndependentTxBody)
sig <- forall a. Arbitrary a => Gen a
arbitrary
      let addr :: BootstrapAddress StandardCrypto
addr = forall c. Address -> BootstrapAddress c
BootstrapAddress Address
byronAddr
          (VKey 'Witness StandardCrypto
shelleyVKey, ChainCode
chainCode) = forall c.
(DSIGN c ~ Ed25519DSIGN) =>
VerificationKey -> (VKey 'Witness c, ChainCode)
unpackByronVKey @StandardCrypto VerificationKey
byronVKey
          wit :: BootstrapWitness StandardCrypto
          wit :: BootstrapWitness StandardCrypto
wit =
            BootstrapWitness
              { bwKey :: VKey 'Witness StandardCrypto
bwKey = VKey 'Witness StandardCrypto
shelleyVKey
              , bwChainCode :: ChainCode
bwChainCode = ChainCode
chainCode
              , bwSig :: SignedDSIGN
  StandardCrypto (Hash StandardCrypto EraIndependentTxBody)
bwSig = SignedDSIGN Ed25519DSIGN (Hash Blake2b_256 EraIndependentTxBody)
sig
              , bwAttributes :: ByteString
bwAttributes = forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer forall a b. (a -> b) -> a -> b
$ Address -> Attributes AddrAttributes
Byron.addrAttributes Address
byronAddr
              }
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
        forall (a :: KeyRole -> * -> *) (r :: KeyRole) c (r' :: KeyRole).
HasKeyRole a =>
a r c -> a r' c
coerceKeyRole (forall c. Crypto c => BootstrapAddress c -> KeyHash 'Payment c
bootstrapKeyHash @StandardCrypto BootstrapAddress StandardCrypto
addr)
          forall a. (Eq a, Show a) => a -> a -> Property
=== forall c. Crypto c => BootstrapWitness c -> KeyHash 'Witness c
bootstrapWitKeyHash BootstrapWitness StandardCrypto
wit

roundTripAddressSpec :: Spec
roundTripAddressSpec :: Spec
roundTripAddressSpec = do
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CompactAddr" forall a b. (a -> b) -> a -> b
$ do
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(CompactAddr StandardCrypto)
    forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"compactAddr/decompactAddr round trip" forall a b. (a -> b) -> a -> b
$
      forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll forall c. Crypto c => Gen (Addr c)
genAddrBadPtr forall a b. (a -> b) -> a -> b
$
        forall c. Crypto c => Addr c -> Property
propCompactAddrRoundTrip @StandardCrypto
    forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Compact address binary representation" forall a b. (a -> b) -> a -> b
$
      forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll forall c. Crypto c => Gen (Addr c)
genAddrBadPtr forall a b. (a -> b) -> a -> b
$
        forall c. Addr c -> Property
propCompactSerializationAgree @StandardCrypto
    forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Ensure Addr failures on incorrect binary data" forall a b. (a -> b) -> a -> b
$
      forall c. Crypto c => Addr c -> Gen Property
propDecompactErrors @StandardCrypto
    forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Ensure RewardAcnt failures on incorrect binary data" forall a b. (a -> b) -> a -> b
$
      forall c. Crypto c => Version -> RewardAccount c -> Gen Property
propDeserializeRewardAccountErrors @StandardCrypto
    forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"RoundTrip-invalid" forall a b. (a -> b) -> a -> b
$
      forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll forall c. Crypto c => Gen (CompactAddr c)
genCompactAddrBadPtr forall a b. (a -> b) -> a -> b
$
        forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> Version -> Version -> t -> Expectation
roundTripRangeExpectation @(CompactAddr StandardCrypto)
          forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip
          (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2)
          (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @6)
    forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Decompact addr with junk" forall a b. (a -> b) -> a -> b
$
      forall c.
(HasCallStack, Crypto c) =>
Addr c -> ByteString -> Expectation
propDecompactAddrWithJunk @StandardCrypto
    forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Same as old decompactor" forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => CompactAddr c -> Expectation
propSameAsOldDecompactAddr @StandardCrypto
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fail on extraneous bytes" forall a b. (a -> b) -> a -> b
$
      forall c (m :: * -> *).
(Crypto c, MonadFail m) =>
ByteString -> m (Addr c)
decodeAddr @StandardCrypto HasCallStack => ByteString
addressWithExtraneousBytes forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall a. Maybe a
Nothing
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Addr" forall a b. (a -> b) -> a -> b
$ do
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(Addr StandardCrypto)
    forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"RoundTrip-invalid" forall a b. (a -> b) -> a -> b
$
      forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll forall c. Crypto c => Gen (Addr c)
genAddrBadPtr forall a b. (a -> b) -> a -> b
$
        forall t.
(Show t, Eq t, Typeable t, HasCallStack) =>
Trip t t -> Version -> Version -> t -> Expectation
roundTripRangeExpectation @(Addr StandardCrypto) forall a b. (EncCBOR a, DecCBOR b) => Trip a b
cborTrip (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2) (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @6)
    forall prop.
(HasCallStack, Testable prop) =>
String -> prop -> Spec
prop String
"Deserializing an address matches old implementation" forall a b. (a -> b) -> a -> b
$
      forall c. (HasCallStack, Crypto c) => Addr c -> Property
propValidateNewDeserialize @StandardCrypto
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"RewardAcnt" forall a b. (a -> b) -> a -> b
$ do
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @(RewardAccount StandardCrypto)

propSameAsOldDecompactAddr :: forall c. Crypto c => CompactAddr c -> Expectation
propSameAsOldDecompactAddr :: forall c. Crypto c => CompactAddr c -> Expectation
propSameAsOldDecompactAddr CompactAddr c
cAddr = do
  Addr c
addr forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall c. Crypto c => CompactAddr c -> Addr c
decompactAddrOld @c CompactAddr c
cAddr
  Addr c
addr forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` forall c. Crypto c => CompactAddr c -> Addr c
decompactAddrOldLazy @c CompactAddr c
cAddr
  where
    addr :: Addr c
addr = forall c. (HasCallStack, Crypto c) => CompactAddr c -> Addr c
decompactAddr @c CompactAddr c
cAddr

propDecompactAddrWithJunk ::
  forall c.
  (HasCallStack, Crypto c) =>
  Addr c ->
  BS.ByteString ->
  Expectation
propDecompactAddrWithJunk :: forall c.
(HasCallStack, Crypto c) =>
Addr c -> ByteString -> Expectation
propDecompactAddrWithJunk Addr c
addr ByteString
junk = do
  -- Add garbage to the end of serialized non-Byron address
  ByteString
bs <- case Addr c
addr of
    AddrBootstrap BootstrapAddress c
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall c. Addr c -> ByteString
serialiseAddr Addr c
addr
    Addr c
_ -> do
      let bs :: ByteString
bs = forall c. Addr c -> ByteString
serialiseAddr Addr c
addr forall a. Semigroup a => a -> a -> a
<> ByteString
junk
      -- ensure we fail decoding of compact addresses with junk at the end
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
BS.length ByteString
junk forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @7 .. forall a. Bounded a => a
maxBound] forall a b. (a -> b) -> a -> b
$ \Version
version -> do
          let cbor :: ByteString
cbor = forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
version ByteString
bs
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull' Version
version ByteString
cbor) forall a b. (a -> b) -> a -> b
$ \(CompactAddr c
cAddr :: CompactAddr c) ->
            HasCallStack => String -> Expectation
expectationFailure forall a b. (a -> b) -> a -> b
$
              [String] -> String
unlines
                [ String
"Decoding with version: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Version
version
                , String
"unexpectedly was able to parse an address with junk at the end: "
                , forall a. Show a => a -> String
show ByteString
cbor
                , String
"as: "
                , forall a. Show a => a -> String
show CompactAddr c
cAddr
                ]
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs
  -- Ensure we drop off the junk at the end all the way through Alonzo
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [forall a. Bounded a => a
minBound .. forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @6] forall a b. (a -> b) -> a -> b
$ \Version
version -> do
    -- Encode with garbage
    let cbor :: ByteString
cbor = forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
version ByteString
bs
    -- Decode as compact address
    CompactAddr c
cAddr :: CompactAddr c <-
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
decodeFull' Version
version ByteString
cbor
    -- Ensure that garbage is gone (decodeAddr will fail otherwise)
    forall c (m :: * -> *).
(Crypto c, MonadFail m) =>
ByteString -> m (Addr c)
decodeAddr (forall c. Addr c -> ByteString
serialiseAddr (forall c. (HasCallStack, Crypto c) => CompactAddr c -> Addr c
decompactAddr CompactAddr c
cAddr)) forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Addr c
addr

propValidateNewDeserialize :: forall c. (HasCallStack, Crypto c) => Addr c -> Property
propValidateNewDeserialize :: forall c. (HasCallStack, Crypto c) => Addr c -> Property
propValidateNewDeserialize Addr c
addr = forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ do
  let bs :: ByteString
bs = forall c. Addr c -> ByteString
serialiseAddr Addr c
addr
      deserializedOld :: Addr c
deserializedOld = forall a. HasCallStack => Fail a -> a
errorFail forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *).
(Crypto c, MonadFail m) =>
ByteString -> m (Addr c)
deserialiseAddrOld @c ByteString
bs
      deserializedNew :: Addr c
deserializedNew = forall a. HasCallStack => Fail a -> a
errorFail forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *).
(Crypto c, MonadFail m) =>
ByteString -> m (Addr c)
decodeAddr @c ByteString
bs
  Addr c
deserializedNew forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Addr c
addr
  Addr c
deserializedOld forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Addr c
deserializedNew

propCompactAddrRoundTrip :: Crypto c => Addr c -> Property
propCompactAddrRoundTrip :: forall c. Crypto c => Addr c -> Property
propCompactAddrRoundTrip Addr c
addr =
  let compact :: CompactAddr c
compact = forall c. Addr c -> CompactAddr c
compactAddr Addr c
addr
      decompact :: Addr c
decompact = forall c. (HasCallStack, Crypto c) => CompactAddr c -> Addr c
decompactAddr CompactAddr c
compact
   in Addr c
addr forall a. (Eq a, Show a) => a -> a -> Property
=== Addr c
decompact

propCompactSerializationAgree :: Addr c -> Property
propCompactSerializationAgree :: forall c. Addr c -> Property
propCompactSerializationAgree Addr c
addr =
  let sbs :: ShortByteString
sbs = forall c. CompactAddr c -> ShortByteString
unCompactAddr forall a b. (a -> b) -> a -> b
$ forall c. Addr c -> CompactAddr c
compactAddr Addr c
addr
   in ShortByteString
sbs forall a. (Eq a, Show a) => a -> a -> Property
=== ByteString -> ShortByteString
SBS.toShort (forall c. Addr c -> ByteString
serialiseAddr Addr c
addr)

propDecompactErrors :: forall c. Crypto c => Addr c -> Gen Property
propDecompactErrors :: forall c. Crypto c => Addr c -> Gen Property
propDecompactErrors Addr c
addr = do
  let sbs :: ShortByteString
sbs = forall c. CompactAddr c -> ShortByteString
unCompactAddr forall a b. (a -> b) -> a -> b
$ forall c. Addr c -> CompactAddr c
compactAddr Addr c
addr
      hashLen :: Int
hashLen = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
Hash.sizeHash (forall {k} (t :: k). Proxy t
Proxy :: Proxy (ADDRHASH c))
      bs :: ByteString
bs = ShortByteString -> ByteString
SBS.fromShort ShortByteString
sbs
      flipHeaderBit :: Int -> ByteString
flipHeaderBit Int
b =
        case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs of
          Just (Word8
h, ByteString
bsTail) -> Word8 -> ByteString -> ByteString
BS.cons (forall a. Bits a => a -> Int -> a
complementBit Word8
h Int
b) ByteString
bsTail
          Maybe (Word8, ByteString)
Nothing -> forall a. HasCallStack => String -> a
error String
"Impossible: CompactAddr can't be empty"
      mingleHeader :: Gen (String, ByteString)
mingleHeader = do
        Int
b <- forall a. HasCallStack => [a] -> Gen a
elements forall a b. (a -> b) -> a -> b
$ case Addr c
addr of
          Addr {} -> [Int
1, Int
2, Int
3, Int
7]
          AddrBootstrap {} -> [Int
0 .. Int
7]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"Header", Int -> ByteString
flipHeaderBit Int
b)
      mingleAddLength :: Gen (String, ByteString)
mingleAddLength = do
        NonEmpty [Word8]
xs <- forall a. Arbitrary a => Gen a
arbitrary
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"Add Length", ByteString
bs forall a. Semigroup a => a -> a -> a
<> [Word8] -> ByteString
BS.pack [Word8]
xs)
      mingleDropLength :: Gen (String, ByteString)
mingleDropLength = do
        Int
n <- (Int, Int) -> Gen Int
chooseInt (Int
1, ByteString -> Int
BS.length ByteString
bs)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"Drop Length", Int -> ByteString -> ByteString
BS.take (ByteString -> Int
BS.length ByteString
bs forall a. Num a => a -> a -> a
- Int
n) ByteString
bs)
      mingleStaking :: Gen (String, ByteString)
mingleStaking = do
        let (ByteString
prefix, ByteString
suffix) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Int
1 forall a. Num a => a -> a -> a
+ Int
hashLen) ByteString
bs
            genBad32 :: Gen Put
genBad32 =
              Word64 -> Put
putVariableLengthWord64
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word32) forall a. Num a => a -> a -> a
+ Word64
1, forall a. Bounded a => a
maxBound :: Word64)
            genBad16 :: Gen Put
genBad16 =
              Word64 -> Put
putVariableLengthWord64
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Random a => (a, a) -> Gen a
choose (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word16) forall a. Num a => a -> a -> a
+ Word64
1, forall a. Bounded a => a
maxBound :: Word64)
            genGood32 :: Gen Put
genGood32 =
              Word64 -> Put
putVariableLengthWord64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word32 -> Word64) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
            genGood16 :: Gen Put
genGood16 =
              Word64 -> Put
putVariableLengthWord64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word16 -> Word64) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
            serializeSuffix :: [f Put] -> f ByteString
serializeSuffix [f Put]
xs = ByteString -> ByteString
BSL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
B.runPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [f Put]
xs
        case Addr c
addr of
          Addr Network
_ PaymentCredential c
_ StakeRefPtr {} -> do
            ByteString
newSuffix <-
              forall a. HasCallStack => [Gen a] -> Gen a
oneof
                [ forall {f :: * -> *}. Monad f => [f Put] -> f ByteString
serializeSuffix [Gen Put
genBad32, Gen Put
genGood16, Gen Put
genGood16]
                , forall {f :: * -> *}. Monad f => [f Put] -> f ByteString
serializeSuffix [Gen Put
genGood32, Gen Put
genBad16, Gen Put
genGood16]
                , forall {f :: * -> *}. Monad f => [f Put] -> f ByteString
serializeSuffix [Gen Put
genGood32, Gen Put
genGood16, Gen Put
genBad16]
                , forall {f :: * -> *}. Monad f => [f Put] -> f ByteString
serializeSuffix [Gen Put
genGood32, Gen Put
genGood16, Gen Put
genGood16, Gen Put
genGood16]
                , -- We need to reset the first bit, to indicate that no more bytes do
                  -- follow. Besides the fact that the original suffix is retained, this
                  -- is similar to:
                  --
                  -- serializeSuffix [genGood8, genGood32, genGood16, genGood16]
                  (\Word8
x -> Word8 -> ByteString
BS.singleton (Word8
x forall a. Bits a => a -> a -> a
.&. Word8
0b01111111) forall a. Semigroup a => a -> a -> a
<> ByteString
suffix) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
                ]
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"Mingle Ptr", ByteString
prefix forall a. Semigroup a => a -> a -> a
<> ByteString
newSuffix)
          Addr Network
_ PaymentCredential c
_ StakeRefNull {} -> do
            NonEmpty [Word8]
xs <- forall a. Arbitrary a => Gen a
arbitrary
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"Bogus Null Ptr", ByteString
prefix forall a. Semigroup a => a -> a -> a
<> [Word8] -> ByteString
BS.pack [Word8]
xs)
          Addr Network
_ PaymentCredential c
_ StakeRefBase {} -> do
            [Word8]
xs <- forall a. Arbitrary a => Gen a
arbitrary
            let xs' :: [Word8]
xs' = if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
xs forall a. Eq a => a -> a -> Bool
== Int
hashLen then Word8
0 forall a. a -> [a] -> [a]
: [Word8]
xs else [Word8]
xs
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"Bogus Staking", ByteString
prefix forall a. Semigroup a => a -> a -> a
<> [Word8] -> ByteString
BS.pack [Word8]
xs')
          AddrBootstrap {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"Bogus Bootstrap", Word8 -> ByteString
BS.singleton Word8
0b10000000 forall a. Semigroup a => a -> a -> a
<> ByteString
bs)
  (String
mingler, ByteString
badAddr) <-
    forall a. HasCallStack => [Gen a] -> Gen a
oneof
      [ Gen (String, ByteString)
mingleHeader
      , Gen (String, ByteString)
mingleAddLength
      , Gen (String, ByteString)
mingleDropLength
      , Gen (String, ByteString)
mingleStaking
      ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ forall prop. Testable prop => String -> prop -> Property
counterexample
      (String
"Mingled address with " forall a. [a] -> [a] -> [a]
++ String
mingler forall a. [a] -> [a] -> [a]
++ String
" was parsed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
badAddr)
    forall a b. (a -> b) -> a -> b
$ forall a b. Either a b -> Bool
isLeft
    forall a b. (a -> b) -> a -> b
$ forall c. Crypto c => ByteString -> Either String (Addr c)
decodeAddrEither @c ByteString
badAddr

propDeserializeRewardAccountErrors ::
  forall c. Crypto c => Version -> RewardAccount c -> Gen Property
propDeserializeRewardAccountErrors :: forall c. Crypto c => Version -> RewardAccount c -> Gen Property
propDeserializeRewardAccountErrors Version
v RewardAccount c
acnt = do
  let bs :: ByteString
bs = forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
v RewardAccount c
acnt
      flipHeaderBit :: Int -> ByteString
flipHeaderBit Int
b =
        case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs of
          Just (Word8
h, ByteString
bsTail) -> Word8 -> ByteString -> ByteString
BS.cons (forall a. Bits a => a -> Int -> a
complementBit Word8
h Int
b) ByteString
bsTail
          Maybe (Word8, ByteString)
Nothing -> forall a. HasCallStack => String -> a
error String
"Impossible: CompactAddr can't be empty"
      mingleHeader :: Gen (String, ByteString)
mingleHeader = do
        Int
b <- forall a. HasCallStack => [a] -> Gen a
elements [Int
1, Int
2, Int
3, Int
5, Int
6, Int
7]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"Header", Int -> ByteString
flipHeaderBit Int
b)
      mingleAddLength :: Gen (String, ByteString)
mingleAddLength = do
        NonEmpty [Word8]
xs <- forall a. Arbitrary a => Gen a
arbitrary
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"Add Length", ByteString
bs forall a. Semigroup a => a -> a -> a
<> [Word8] -> ByteString
BS.pack [Word8]
xs)
      mingleDropLength :: Gen (String, ByteString)
mingleDropLength = do
        Int
n <- (Int, Int) -> Gen Int
chooseInt (Int
1, ByteString -> Int
BS.length ByteString
bs)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
"Drop Length", Int -> ByteString -> ByteString
BS.take (ByteString -> Int
BS.length ByteString
bs forall a. Num a => a -> a -> a
- Int
n) ByteString
bs)
  (String
mingler, ByteString
badAddr) <-
    forall a. HasCallStack => [Gen a] -> Gen a
oneof
      [ Gen (String, ByteString)
mingleHeader
      , Gen (String, ByteString)
mingleAddLength
      , Gen (String, ByteString)
mingleDropLength
      ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ forall prop. Testable prop => String -> prop -> Property
counterexample
      (String
"Mingled address with " forall a. [a] -> [a] -> [a]
++ String
mingler forall a. [a] -> [a] -> [a]
++ String
" was parsed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
badAddr)
    forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Bool
isNothing
    forall a b. (a -> b) -> a -> b
$ forall c b (m :: * -> *).
(Crypto c, AddressBuffer b, MonadFail m) =>
b -> m (RewardAcnt c)
decodeRewardAccount @c ByteString
badAddr

addressWithExtraneousBytes :: HasCallStack => BS.ByteString
addressWithExtraneousBytes :: HasCallStack => ByteString
addressWithExtraneousBytes = ByteString
bs
  where
    bs :: ByteString
bs = case ByteString -> Either String ByteString
B16.decode ByteString
hs of
      Left String
e -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
e
      Right ByteString
x -> ByteString
x
    hs :: ByteString
hs =
      ByteString
"01AA5C8B35A934ED83436ABB56CDB44878DAC627529D2DA0B59CDA794405931B9359\
      \46E9391CABDFFDED07EB727F94E9E0F23739FF85978905BD460158907C589B9F1A62"