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

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.Hashes (ADDRHASH)
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 =
  [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"Address" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    Spec
roundTripAddressSpec
    [Char] -> Gen Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"rebuild the 'addr root' using a bootstrap witness" (Gen Property -> Spec) -> Gen Property -> Spec
forall a b. (a -> b) -> a -> b
$ do
      (VerificationKey
byronVKey, Address
byronAddr) <- Gen (VerificationKey, Address)
genByronVKeyAddr
      SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
sig <- Gen (SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody))
forall a. Arbitrary a => Gen a
arbitrary
      let addr :: BootstrapAddress
addr = Address -> BootstrapAddress
BootstrapAddress Address
byronAddr
          (VKey 'Witness
shelleyVKey, ChainCode
chainCode) = VerificationKey -> (VKey 'Witness, ChainCode)
unpackByronVKey VerificationKey
byronVKey
          wit :: BootstrapWitness
          wit :: BootstrapWitness
wit =
            BootstrapWitness
              { bwKey :: VKey 'Witness
bwKey = VKey 'Witness
shelleyVKey
              , bwChainCode :: ChainCode
bwChainCode = ChainCode
chainCode
              , bwSignature :: SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
bwSignature = SignedDSIGN DSIGN (Hash HASH EraIndependentTxBody)
sig
              , bwAttributes :: ByteString
bwAttributes = Version -> Attributes AddrAttributes -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
byronProtVer (Attributes AddrAttributes -> ByteString)
-> Attributes AddrAttributes -> ByteString
forall a b. (a -> b) -> a -> b
$ Address -> Attributes AddrAttributes
Byron.addrAttributes Address
byronAddr
              }
      Property -> Gen Property
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> Gen Property) -> Property -> Gen Property
forall a b. (a -> b) -> a -> b
$
        KeyHash 'Payment -> KeyHash 'Witness
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole (BootstrapAddress -> KeyHash 'Payment
bootstrapKeyHash BootstrapAddress
addr)
          KeyHash 'Witness -> KeyHash 'Witness -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== BootstrapWitness -> KeyHash 'Witness
bootstrapWitKeyHash BootstrapWitness
wit

roundTripAddressSpec :: Spec
roundTripAddressSpec :: Spec
roundTripAddressSpec = do
  [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"CompactAddr" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @CompactAddr
    [Char] -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"compactAddr/decompactAddr round trip" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen Addr -> (Addr -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Addr
genAddrBadPtr ((Addr -> Property) -> Property) -> (Addr -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
        Addr -> Property
propCompactAddrRoundTrip
    [Char] -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Compact address binary representation" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen Addr -> (Addr -> Property) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Addr
genAddrBadPtr ((Addr -> Property) -> Property) -> (Addr -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
        Addr -> Property
propCompactSerializationAgree
    [Char] -> (Addr -> Gen Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Ensure Addr failures on incorrect binary data" ((Addr -> Gen Property) -> Spec) -> (Addr -> Gen Property) -> Spec
forall a b. (a -> b) -> a -> b
$
      Addr -> Gen Property
propDecompactErrors
    [Char] -> (Version -> RewardAccount -> Gen Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Ensure RewardAccount failures on incorrect binary data" ((Version -> RewardAccount -> Gen Property) -> Spec)
-> (Version -> RewardAccount -> Gen Property) -> Spec
forall a b. (a -> b) -> a -> b
$
      Version -> RewardAccount -> Gen Property
propDeserializeRewardAccountErrors
    [Char] -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"RoundTrip-invalid" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen CompactAddr -> (CompactAddr -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen CompactAddr
genCompactAddrBadPtr ((CompactAddr -> Expectation) -> Property)
-> (CompactAddr -> Expectation) -> Property
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
          Trip CompactAddr CompactAddr
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)
    [Char] -> (Addr -> ByteString -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Decompact addr with junk" ((Addr -> ByteString -> Expectation) -> Spec)
-> (Addr -> ByteString -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$
      HasCallStack => Addr -> ByteString -> Expectation
Addr -> ByteString -> Expectation
propDecompactAddrWithJunk
    [Char] -> (CompactAddr -> Expectation) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Same as old decompactor" ((CompactAddr -> Expectation) -> Spec)
-> (CompactAddr -> Expectation) -> Spec
forall a b. (a -> b) -> a -> b
$ CompactAddr -> Expectation
propSameAsOldDecompactAddr
    [Char] -> Expectation -> SpecM (Arg Expectation) ()
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"fail on extraneous bytes" (Expectation -> SpecM (Arg Expectation) ())
-> Expectation -> SpecM (Arg Expectation) ()
forall a b. (a -> b) -> a -> b
$
      ByteString -> Maybe Addr
forall (m :: * -> *). MonadFail m => ByteString -> m Addr
decodeAddr ByteString
HasCallStack => ByteString
addressWithExtraneousBytes Maybe Addr -> Maybe Addr -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Maybe Addr
forall a. Maybe a
Nothing
  [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"Addr" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @Addr
    [Char] -> Property -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"RoundTrip-invalid" (Property -> Spec) -> Property -> Spec
forall a b. (a -> b) -> a -> b
$
      Gen Addr -> (Addr -> Expectation) -> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll Gen Addr
genAddrBadPtr ((Addr -> Expectation) -> Property)
-> (Addr -> Expectation) -> Property
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 Trip Addr Addr
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)
    [Char] -> (Addr -> Property) -> Spec
forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Deserializing an address matches old implementation" ((Addr -> Property) -> Spec) -> (Addr -> Property) -> Spec
forall a b. (a -> b) -> a -> b
$
      HasCallStack => Addr -> Property
Addr -> Property
propValidateNewDeserialize
  [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"RewardAccount" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    forall t. (Show t, Eq t, Arbitrary t, EncCBOR t, DecCBOR t) => Spec
roundTripCborSpec @RewardAccount

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

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

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

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

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

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

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

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