{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Mary.ValueSpec (spec) where

import Cardano.Ledger.BaseTypes (natVersion)
import Cardano.Ledger.Coin (Coin (Coin))
import Cardano.Ledger.Compactible (fromCompact, toCompact)
import Cardano.Ledger.Core (eraProtVerLow)
import Cardano.Ledger.Crypto (Crypto, StandardCrypto)
import Cardano.Ledger.Mary (Mary)
import Cardano.Ledger.Mary.Value
import Control.Exception (AssertionFailed (AssertionFailed), evaluate)
import qualified Data.ByteString.Base16 as BS16
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Short as SBS
import Data.CanonicalMaps (canonicalInsert)
import Data.Maybe (fromJust)
import GHC.Exts
import Test.Cardano.Data
import Test.Cardano.Ledger.Binary.RoundTrip (
  roundTripCborExpectation,
  roundTripCborFailureExpectation,
  roundTripCborRangeExpectation,
  roundTripCborRangeFailureExpectation,
 )
import Test.Cardano.Ledger.Common
import Test.Cardano.Ledger.Mary.Arbitrary (
  genEmptyMultiAsset,
  genMaryValue,
  genMultiAsset,
  genMultiAssetToFail,
  genMultiAssetZero,
  genNegativeInt,
 )

spec :: Spec
spec :: Spec
spec = do
  forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"MultiAsset" forall a b. (a -> b) -> a -> b
$ do
    forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Canonical construction agrees" forall a b. (a -> b) -> a -> b
$
      forall prop. Testable prop => Int -> prop -> Property
withMaxSuccess Int
10000 forall a b. (a -> b) -> a -> b
$
        forall c.
Crypto c =>
[(PolicyID c, AssetName, Integer)]
-> [(PolicyID c, AssetName, Integer)] -> Property
propCanonicalConstructionAgrees @StandardCrypto
  forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"CBOR roundtrip" forall a b. (a -> b) -> a -> b
$ do
    forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
context [Char]
"Coin" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Non-negative Coin succeeds for all eras" forall a b. (a -> b) -> a -> b
$
        \(NonNegative Integer
i) -> forall t.
(Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
t -> Expectation
roundTripCborExpectation (Integer -> Coin
Coin Integer
i)
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Negative Coin succeeds for pre-Conway" forall a b. (a -> b) -> a -> b
$
        \(Negative Integer
i) -> forall t.
(Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripCborRangeExpectation forall a. Bounded a => a
minBound (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @8) (Integer -> Coin
Coin Integer
i)
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Negative Coin fails to deserialise for Conway" forall a b. (a -> b) -> a -> b
$
        \(Negative Integer
i) -> forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripCborRangeFailureExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) (Integer -> Coin
Coin Integer
i)
    forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
context [Char]
"MultiAsset" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Non-zero-valued MultiAsset succeeds for all eras" forall a b. (a -> b) -> a -> b
$
        forall t.
(Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
t -> Expectation
roundTripCborExpectation @(MultiAsset StandardCrypto)
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Zero-valued MultiAsset fails for Conway" 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 (MultiAsset c)
genMultiAssetZero @StandardCrypto) forall a b. (a -> b) -> a -> b
$
          forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripCborRangeFailureExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) forall a. Bounded a => a
maxBound
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Empty MultiAsset fails for Conway" 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 (MultiAsset c)
genEmptyMultiAsset @StandardCrypto) forall a b. (a -> b) -> a -> b
$
          forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripCborRangeFailureExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) forall a. Bounded a => a
maxBound
    forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
context [Char]
"MaryValue" forall a b. (a -> b) -> a -> b
$ do
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Positive MaryValue succeeds for all eras" forall a b. (a -> b) -> a -> b
$ \(MaryValue StandardCrypto
mv :: MaryValue StandardCrypto) ->
        forall t.
(Show t, Eq t, EncCBOR t, DecCBOR t, HasCallStack) =>
t -> Expectation
roundTripCborExpectation MaryValue StandardCrypto
mv
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Negative MaryValue fails for all eras" forall a b. (a -> b) -> a -> b
$
        forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll
          (forall c. Gen (MultiAsset c) -> Gen (MaryValue c)
genMaryValue (forall c. Crypto c => Gen Integer -> Gen (MultiAsset c)
genMultiAsset @StandardCrypto (forall a. Integral a => a -> Integer
toInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
genNegativeInt)))
          forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
t -> Expectation
roundTripCborFailureExpectation
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Zero MaryValue fails for Conway" forall a b. (a -> b) -> a -> b
$
        forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall c. Gen (MultiAsset c) -> Gen (MaryValue c)
genMaryValue (forall c. Crypto c => Gen (MultiAsset c)
genMultiAssetZero @StandardCrypto)) forall a b. (a -> b) -> a -> b
$
          forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripCborRangeFailureExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) forall a. Bounded a => a
maxBound
      forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Empty MaryValue fails for Conway" forall a b. (a -> b) -> a -> b
$
        forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall c. Gen (MultiAsset c) -> Gen (MaryValue c)
genMaryValue (forall c. Crypto c => Gen (MultiAsset c)
genEmptyMultiAsset @StandardCrypto)) forall a b. (a -> b) -> a -> b
$
          forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripCborRangeFailureExpectation (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) forall a. Bounded a => a
maxBound
      forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"Too many assets should fail" forall a b. (a -> b) -> a -> b
$
        forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$
          forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll
            (forall c. Gen (MultiAsset c) -> Gen (MaryValue c)
genMaryValue (forall c. Crypto c => Bool -> Gen (MultiAsset c)
genMultiAssetToFail @StandardCrypto Bool
True))
            ( forall t.
(EncCBOR t, DecCBOR t, Eq t, HasCallStack) =>
Version -> Version -> t -> Expectation
roundTripCborRangeFailureExpectation @(MaryValue StandardCrypto)
                (forall era. Era era => Version
eraProtVerLow @Mary)
                forall a. Bounded a => a
maxBound
            )
  forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"MaryValue compacting" forall a b. (a -> b) -> a -> b
$ do
    forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Canonical generator" forall a b. (a -> b) -> a -> b
$
      \(MaryValue StandardCrypto
ma :: MaryValue StandardCrypto) ->
        forall a. Compactible a => CompactForm a -> a
fromCompact (forall a. HasCallStack => Maybe a -> a
fromJust (forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact MaryValue StandardCrypto
ma)) forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` MaryValue StandardCrypto
ma
    forall prop.
(HasCallStack, Testable prop) =>
[Char] -> prop -> Spec
prop [Char]
"Failing generator" forall a b. (a -> b) -> a -> b
$
      forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> prop) -> Property
forAll (forall c. Gen (MultiAsset c) -> Gen (MaryValue c)
genMaryValue (forall c. Crypto c => Bool -> Gen (MultiAsset c)
genMultiAssetToFail @StandardCrypto Bool
True)) forall a b. (a -> b) -> a -> b
$
        \MaryValue StandardCrypto
ma ->
          forall a. a -> IO a
evaluate (forall a. Compactible a => CompactForm a -> a
fromCompact (forall a. HasCallStack => Maybe a -> a
fromJust (forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact MaryValue StandardCrypto
ma)))
            forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow` (\(AssertionFailed [Char]
errorMsg) -> forall a. Int -> [a] -> [a]
take Int
16 [Char]
errorMsg forall a. Eq a => a -> a -> Bool
== [Char]
"Assertion failed")

instance IsString AssetName where
  fromString :: [Char] -> AssetName
fromString = ShortByteString -> AssetName
AssetName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => [Char] -> a
error ByteString -> ShortByteString
SBS.toShort forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either [Char] ByteString
BS16.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
BS8.pack

propCanonicalConstructionAgrees ::
  Crypto c =>
  [(PolicyID c, AssetName, Integer)] ->
  [(PolicyID c, AssetName, Integer)] ->
  Property
propCanonicalConstructionAgrees :: forall c.
Crypto c =>
[(PolicyID c, AssetName, Integer)]
-> [(PolicyID c, AssetName, Integer)] -> Property
propCanonicalConstructionAgrees [(PolicyID c, AssetName, Integer)]
xs [(PolicyID c, AssetName, Integer)]
ys = forall prop. Testable prop => prop -> Property
property forall a b. (a -> b) -> a -> b
$ do
  let ma1 :: MultiAsset c
ma1@(MultiAsset Map (PolicyID c) (Map AssetName Integer)
a1) = forall era. [(PolicyID era, AssetName, Integer)] -> MultiAsset era
multiAssetFromList [(PolicyID c, AssetName, Integer)]
xs
      ma2 :: MultiAsset c
ma2@(MultiAsset Map (PolicyID c) (Map AssetName Integer)
a2) = forall era. [(PolicyID era, AssetName, Integer)] -> MultiAsset era
multiAssetFromList [(PolicyID c, AssetName, Integer)]
ys
  forall k a.
(HasCallStack, Ord k, Show k, Show a) =>
Map k a -> Expectation
expectValidMap Map (PolicyID c) (Map AssetName Integer)
a1
  forall k a.
(HasCallStack, Ord k, Show k, Show a) =>
Map k a -> Expectation
expectValidMap Map (PolicyID c) (Map AssetName Integer)
a2
  let mb1 :: MultiAsset c
mb1@(MultiAsset Map (PolicyID c) (Map AssetName Integer)
b1) =
        forall a. Monoid a => [a] -> a
mconcat
          [ forall c. Map (PolicyID c) (Map AssetName Integer) -> MultiAsset c
MultiAsset forall a b. (a -> b) -> a -> b
$
              forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert forall a b. a -> b -> a
const PolicyID c
pid (forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert forall a b. a -> b -> a
const AssetName
an Integer
i forall a. Monoid a => a
mempty) forall a. Monoid a => a
mempty
          | (PolicyID c
pid, AssetName
an, Integer
i) <- [(PolicyID c, AssetName, Integer)]
xs
          ]
      mb2 :: MultiAsset c
mb2@(MultiAsset Map (PolicyID c) (Map AssetName Integer)
b2) =
        forall a. Monoid a => [a] -> a
mconcat
          [ forall c. Map (PolicyID c) (Map AssetName Integer) -> MultiAsset c
MultiAsset forall a b. (a -> b) -> a -> b
$
              forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert forall a b. a -> b -> a
const PolicyID c
pid (forall k a.
(Ord k, CanonicalZero a) =>
(a -> a -> a) -> k -> a -> Map k a -> Map k a
canonicalInsert forall a b. a -> b -> a
const AssetName
an Integer
i forall a. Monoid a => a
mempty) forall a. Monoid a => a
mempty
          | (PolicyID c
pid, AssetName
an, Integer
i) <- [(PolicyID c, AssetName, Integer)]
ys
          ]
  forall k a.
(HasCallStack, Ord k, Show k, Show a) =>
Map k a -> Expectation
expectValidMap Map (PolicyID c) (Map AssetName Integer)
b1
  forall k a.
(HasCallStack, Ord k, Show k, Show a) =>
Map k a -> Expectation
expectValidMap Map (PolicyID c) (Map AssetName Integer)
b2
  MultiAsset c
ma1 forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` MultiAsset c
mb1
  MultiAsset c
ma2 forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` MultiAsset c
mb2
  MultiAsset c
ma1 forall a. Semigroup a => a -> a -> a
<> MultiAsset c
ma2 forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` MultiAsset c
mb1 forall a. Semigroup a => a -> a -> a
<> MultiAsset c
mb2
  MultiAsset c
ma1 forall a. Semigroup a => a -> a -> a
<> MultiAsset c
mb2 forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` MultiAsset c
mb1 forall a. Semigroup a => a -> a -> a
<> MultiAsset c
ma2