Merge pull request #755 from IntersectMBO/fix-estimate-transaction-key-witness-count

Modify `estimateTransactionKeyWitnessCount` to estimate simple scripts too

Author: palas

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -132,6 +132,7 @@ module Test.Gen.Cardano.Api.Typed
   , genProposals
   , genProposal
   , genVotingProcedures
+  , genSimpleScriptWithoutEmptyAnys
   )
 where
 
@@ -233,8 +234,23 @@ genScript SimpleScriptLanguage =
 genScript (PlutusScriptLanguage lang) =
   PlutusScript lang <$> genPlutusScript lang
 
+genSimpleScriptWithoutEmptyAnys :: Gen SimpleScript
+genSimpleScriptWithoutEmptyAnys = genRandomSimpleScript False
+
 genSimpleScript :: Gen SimpleScript
-genSimpleScript =
+genSimpleScript = genRandomSimpleScript True
+
+-- | We include a @hasEmptyAnys@ parameter to control whether we allow empty
+-- 'RequireAnyOf' constructors. This is because an empty 'RequireAnyOf',
+-- same as a 'RequireMOf' with less than M elements, is not satisfiable.
+-- In the function @satisfyScript@ in the "Test.Cardano.Api.TxBody" module,
+-- we look for a set of witnesses that satisfy a script, and we can't do it
+-- if the script consists of an empty 'RequireAnyOf' constructor.
+-- Note that this is not the only way to make an unsatisfiable script,
+-- but this is the one that affects the @satisfyScript@ function, because
+-- it is only concerned with the witnesses, and not with the times.
+genRandomSimpleScript :: Bool -> Gen SimpleScript
+genRandomSimpleScript hasEmptyAnys =
   genTerm
  where
   genTerm = Gen.recursive Gen.choice nonRecursive recursive
@@ -249,7 +265,7 @@ genSimpleScript =
   -- Recursive generators
   recursive =
     [ RequireAllOf <$> Gen.list (Range.linear 0 10) genTerm
-    , RequireAnyOf <$> Gen.list (Range.linear 0 10) genTerm
+    , RequireAnyOf <$> Gen.list (Range.linear (if hasEmptyAnys then 0 else 1) 10) genTerm
     , do
         ts <- Gen.list (Range.linear 0 10) genTerm
         m <- Gen.integral (Range.constant 0 (length ts))

cardano-api/src/Cardano/Api/Internal/Fees.hs

@@ -86,14 +86,20 @@ import Cardano.Ledger.Val qualified as L
 import Ouroboros.Consensus.HardFork.History qualified as Consensus
 
 import Control.Monad
-import Data.Bifunctor (bimap, first, second)
+import Data.Bifunctor
+  ( bimap
+  , first
+  , second
+  )
 import Data.ByteString.Short (ShortByteString)
 import Data.Function ((&))
+import Data.List (sortBy)
 import Data.List qualified as List
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Maybe
 import Data.OSet.Strict qualified as OSet
+import Data.Ord (Down (Down), comparing)
 import Data.Ratio
 import Data.Set (Set)
 import Data.Set qualified as Set
@@ -464,7 +470,7 @@ estimateTransactionKeyWitnessCount
     , txUpdateProposal
     } =
     fromIntegral $
-      length [() | (_txin, BuildTxWith KeyWitness{}) <- txIns]
+      sum (map estimateTxInWitnesses txIns)
         + case txInsCollateral of
           TxInsCollateral _ txins ->
             length txins
@@ -486,6 +492,27 @@ estimateTransactionKeyWitnessCount
           TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) ->
             Map.size updatePerGenesisKey
           _ -> 0
+   where
+    estimateTxInWitnesses :: (TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era)) -> Int
+    estimateTxInWitnesses (_, BuildTxWith (KeyWitness _)) = 1
+    estimateTxInWitnesses (_, BuildTxWith (ScriptWitness _ (SimpleScriptWitness _ (SScript simpleScript)))) = maxWitnessesInSimpleScript simpleScript
+    estimateTxInWitnesses (_, BuildTxWith (ScriptWitness _ (SimpleScriptWitness _ (SReferenceScript _)))) = 0
+    estimateTxInWitnesses (_, BuildTxWith (ScriptWitness _ (PlutusScriptWitness{}))) = 0
+
+    -- This is a rough conservative estimate of the maximum number of witnesses
+    -- needed for a simple script to be satisfied. It is conservative because it
+    -- assumes that each key hash only appears once, and it assumes the worst
+    -- scenario. A more accurate estimate for the maximum could be computed by
+    -- keeping track of the possible combinations of key hashes that have
+    -- potentially already been counted, but that would increase complexity a lot,
+    -- and it would still be a conservative estimate.
+    maxWitnessesInSimpleScript :: SimpleScript -> Int
+    maxWitnessesInSimpleScript (RequireSignature _) = 1
+    maxWitnessesInSimpleScript (RequireTimeBefore _) = 0
+    maxWitnessesInSimpleScript (RequireTimeAfter _) = 0
+    maxWitnessesInSimpleScript (RequireAllOf simpleScripts) = sum $ map maxWitnessesInSimpleScript simpleScripts
+    maxWitnessesInSimpleScript (RequireAnyOf simpleScripts) = maximum $ map maxWitnessesInSimpleScript simpleScripts
+    maxWitnessesInSimpleScript (RequireMOf n simpleScripts) = sum $ take n $ sortBy (comparing Down) (map maxWitnessesInSimpleScript simpleScripts)
 
 -- ----------------------------------------------------------------------------
 -- Script execution units
@@ -841,6 +868,7 @@ data TxBodyErrorAutoBalance era
     -- input ada.
     TxBodyErrorAdaBalanceTooSmall
       -- \^ Offending TxOut
+
       TxOutInAnyEra
       -- ^ Minimum UTxO
       L.Coin
@@ -857,6 +885,7 @@ data TxBodyErrorAutoBalance era
   | -- | The minimum spendable UTxO threshold has not been met.
     TxBodyErrorMinUTxONotMet
       -- \^ Offending TxOut
+
       TxOutInAnyEra
       -- ^ Minimum UTxO
       L.Coin

cardano-api/test/cardano-api-test/Test/Cardano/Api/TxBody.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 {- HLINT ignore "Use camelCase" -}
 
@@ -18,15 +19,24 @@ import Cardano.Api.Ledger qualified as L
 import Cardano.Api.Shelley (ShelleyLedgerEra)
 
 import Data.Maybe (isJust)
-import Data.Type.Equality (TestEquality (testEquality))
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Data.Type.Equality
+  ( TestEquality (testEquality)
+  )
 import GHC.Exts (IsList (..))
 
 import Test.Gen.Cardano.Api.Typed
 
 import Test.Cardano.Api.Orphans ()
 
-import Hedgehog (MonadTest, Property, (===))
+import Hedgehog
+  ( MonadTest
+  , Property
+  , (===)
+  )
 import Hedgehog qualified as H
+import Hedgehog.Gen (shuffle)
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (testProperty)
 
@@ -108,6 +118,38 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do
   getProposalProcedures TxProposalProceduresNone = Nothing
   getProposalProcedures (TxProposalProcedures pp) = Just $ fst <$> toList pp
 
+prop_simple_script_witness_count :: Property
+prop_simple_script_witness_count = H.property $ do
+  let sbe = ShelleyBasedEraConway
+  (_, contentWithoutScript) <- H.forAll $ genValidTxBody sbe
+  script <- H.forAll genSimpleScriptWithoutEmptyAnys
+  newTxIn <-
+    H.forAll $
+      (,BuildTxWith
+          ( ScriptWitness
+              ScriptWitnessForSpending
+              (SimpleScriptWitness SimpleScriptInConway (SScript script))
+          ))
+        <$> genTxIn
+  witList <- H.forAll $ satisfyScript script
+  let witCount = fromIntegral $ Set.size witList
+  -- We use the inequality @<=@ instead of @==@ because 'estimateTransactionKeyWitnessCount'
+  -- calculates an upper bound on the number of key witnesses required to validate a transaction,
+  -- and the @witList@ contains a random subset that can potentially be used to satisfy the script.
+  -- So we only know it must be smaller or equal to the upper bound.
+  H.diff
+    (estimateTransactionKeyWitnessCount contentWithoutScript + witCount)
+    (<=)
+    (estimateTransactionKeyWitnessCount (addTxIn newTxIn contentWithoutScript))
+ where
+  satisfyScript :: SimpleScript -> H.Gen (Set (Hash PaymentKey))
+  satisfyScript (RequireSignature paymentKeyHash) = return $ Set.singleton paymentKeyHash
+  satisfyScript (RequireTimeBefore _) = return mempty
+  satisfyScript (RequireTimeAfter _) = return mempty
+  satisfyScript (RequireAllOf simpleScripts) = Set.unions <$> traverse satisfyScript simpleScripts
+  satisfyScript (RequireMOf n simpleScripts) = shuffle simpleScripts >>= satisfyScript . RequireAllOf . take n
+  satisfyScript (RequireAnyOf simpleScripts) = satisfyScript (RequireMOf 1 simpleScripts)
+
 tests :: TestTree
 tests =
   testGroup
@@ -119,4 +161,7 @@ tests =
     , testProperty
         "roundtrip txbodycontent new conway fields"
         prop_roundtrip_txbodycontent_conway_fields
+    , testProperty
+        "simple script witness count"
+        prop_simple_script_witness_count
     ]