{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Allegra.Imp.UtxowSpec (
  spec,
) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..))
import Cardano.Ledger.Shelley.TxAuxData (Metadatum (..))
import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Word (Word64)
import Lens.Micro
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.Arbitrary (genUtf8StringOfSize)
import Test.Cardano.Ledger.Shelley.ImpTest

spec ::
  forall era.
  ( ShelleyEraImp era
  , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ShelleyEraImp era,
 InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"UTXOW" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"InvalidMetadata" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    Map Word64 Metadatum
invalidMetadatum <- ImpTestM era (Map Word64 Metadatum)
forall era. ImpTestM era (Map Word64 Metadatum)
genInvalidMetadata
    let auxData :: TxAuxData era
auxData = TxAuxData era
forall era. EraTxAuxData era => TxAuxData era
mkBasicTxAuxData TxAuxData era -> (TxAuxData era -> TxAuxData era) -> TxAuxData era
forall a b. a -> (a -> b) -> b
& (Map Word64 Metadatum -> Identity (Map Word64 Metadatum))
-> TxAuxData era -> Identity (TxAuxData era)
forall era.
EraTxAuxData era =>
Lens' (TxAuxData era) (Map Word64 Metadatum)
Lens' (TxAuxData era) (Map Word64 Metadatum)
metadataTxAuxDataL ((Map Word64 Metadatum -> Identity (Map Word64 Metadatum))
 -> TxAuxData era -> Identity (TxAuxData era))
-> Map Word64 Metadatum -> TxAuxData era -> TxAuxData era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Word64 Metadatum
invalidMetadatum
    let auxDataHash :: TxAuxDataHash
auxDataHash = TxAuxData era -> TxAuxDataHash
forall era. EraTxAuxData era => TxAuxData era -> TxAuxDataHash
hashTxAuxData TxAuxData era
auxData
    let tx :: Tx era
tx =
          TxBody era -> Tx era
forall era. EraTx era => TxBody era -> Tx era
mkBasicTx TxBody era
forall era. EraTxBody era => TxBody era
mkBasicTxBody
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (TxBody era -> Identity (TxBody era))
-> Tx era -> Identity (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Identity (TxBody era))
 -> Tx era -> Identity (Tx era))
-> ((StrictMaybe TxAuxDataHash
     -> Identity (StrictMaybe TxAuxDataHash))
    -> TxBody era -> Identity (TxBody era))
-> (StrictMaybe TxAuxDataHash
    -> Identity (StrictMaybe TxAuxDataHash))
-> Tx era
-> Identity (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe TxAuxDataHash -> Identity (StrictMaybe TxAuxDataHash))
-> TxBody era -> Identity (TxBody era)
forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
Lens' (TxBody era) (StrictMaybe TxAuxDataHash)
auxDataHashTxBodyL ((StrictMaybe TxAuxDataHash
  -> Identity (StrictMaybe TxAuxDataHash))
 -> Tx era -> Identity (Tx era))
-> StrictMaybe TxAuxDataHash -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxAuxDataHash -> StrictMaybe TxAuxDataHash
forall a. a -> StrictMaybe a
SJust TxAuxDataHash
auxDataHash
            Tx era -> (Tx era -> Tx era) -> Tx era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (TxAuxData era)
 -> Identity (StrictMaybe (TxAuxData era)))
-> Tx era -> Identity (Tx era)
forall era.
EraTx era =>
Lens' (Tx era) (StrictMaybe (TxAuxData era))
Lens' (Tx era) (StrictMaybe (TxAuxData era))
auxDataTxL ((StrictMaybe (TxAuxData era)
  -> Identity (StrictMaybe (TxAuxData era)))
 -> Tx era -> Identity (Tx era))
-> StrictMaybe (TxAuxData era) -> Tx era -> Tx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxAuxData era -> StrictMaybe (TxAuxData era)
forall a. a -> StrictMaybe a
SJust TxAuxData era
auxData
    Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [ShelleyUtxowPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure ShelleyUtxowPredFailure era
forall era. ShelleyUtxowPredFailure era
InvalidMetadata]

genInvalidMetadata :: ImpTestM era (Map.Map Word64 Metadatum)
genInvalidMetadata :: forall era. ImpTestM era (Map Word64 Metadatum)
genInvalidMetadata = do
  Int
size <- (Int, Int) -> ImpM (LedgerSpec era) Int
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
65, Int
1000)
  let genM :: ImpM (LedgerSpec era) Metadatum
genM =
        [ImpM (LedgerSpec era) Metadatum]
-> ImpM (LedgerSpec era) Metadatum
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
oneof
          [ ByteString -> Metadatum
B (ByteString -> Metadatum)
-> (String -> ByteString) -> String -> Metadatum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack (String -> Metadatum)
-> ImpM (LedgerSpec era) String -> ImpM (LedgerSpec era) Metadatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> ImpM (LedgerSpec era) Char -> ImpM (LedgerSpec era) String
forall (m :: * -> *) a. MonadGen m => Int -> m a -> m [a]
vectorOf Int
size ImpM (LedgerSpec era) Char
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
          , Text -> Metadatum
S (Text -> Metadatum) -> (String -> Text) -> String -> Metadatum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Metadatum)
-> ImpM (LedgerSpec era) String -> ImpM (LedgerSpec era) Metadatum
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen String -> ImpM (LedgerSpec era) String
forall a. Gen a -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. MonadGen g => Gen a -> g a
liftGen (Int -> Gen String
genUtf8StringOfSize Int
size)
          ]
  [(Word64, Metadatum)] -> Map Word64 Metadatum
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Word64, Metadatum)] -> Map Word64 Metadatum)
-> ImpM (LedgerSpec era) [(Word64, Metadatum)]
-> ImpTestM era (Map Word64 Metadatum)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (Word64, Metadatum)
-> ImpM (LedgerSpec era) [(Word64, Metadatum)]
forall (m :: * -> *) a. MonadGen m => m a -> m [a]
listOf1 ((,) (Word64 -> Metadatum -> (Word64, Metadatum))
-> ImpM (LedgerSpec era) Word64
-> ImpM (LedgerSpec era) (Metadatum -> (Word64, Metadatum))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) Word64
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary ImpM (LedgerSpec era) (Metadatum -> (Word64, Metadatum))
-> ImpM (LedgerSpec era) Metadatum
-> ImpM (LedgerSpec era) (Word64, Metadatum)
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImpM (LedgerSpec era) Metadatum
genM)