Data backed constitution script (#6784)

* Add data-backed version of Validator.Common

* Add data-backed test modules

* Add tests

cardano-constitution/cardano-constitution.cabal

@@ -70,9 +70,13 @@ library
     Cardano.Constitution.Config.Instance.FromJSON
     Cardano.Constitution.Config.Instance.TxLift
     Cardano.Constitution.Config.Types
+    Cardano.Constitution.Data.Validator
     Cardano.Constitution.DataFilePaths
     Cardano.Constitution.Validator
     Cardano.Constitution.Validator.Common
+    Cardano.Constitution.Validator.Data.Common
+    Cardano.Constitution.Validator.Data.Sorted
+    Cardano.Constitution.Validator.Data.Unsorted
     Cardano.Constitution.Validator.Sorted
     Cardano.Constitution.Validator.Unsorted
     PlutusTx.NonCanonicalRational
@@ -102,6 +106,10 @@ test-suite cardano-constitution-test
   main-is:          Driver.hs
   other-modules:
     Cardano.Constitution.Config.Tests
+    Cardano.Constitution.Validator.Data.GoldenTests
+    Cardano.Constitution.Validator.Data.PropTests
+    Cardano.Constitution.Validator.Data.TestsCommon
+    Cardano.Constitution.Validator.Data.UnitTests
     Cardano.Constitution.Validator.GoldenTests
     Cardano.Constitution.Validator.PropTests
     Cardano.Constitution.Validator.TestsCommon

cardano-constitution/src/Cardano/Constitution/Data/Validator.hs

@@ -0,0 +1,26 @@
+-- editorconfig-checker-disable-file
+{-# LANGUAGE OverloadedLists #-}
+module Cardano.Constitution.Data.Validator
+    ( module Export
+    , defaultValidators
+    , defaultValidatorsWithCodes
+    ) where
+
+import Cardano.Constitution.Validator.Data.Common as Export
+import Cardano.Constitution.Validator.Data.Sorted qualified as S
+import Cardano.Constitution.Validator.Data.Unsorted qualified as U
+--import Cardano.Constitution.Validator.Reference.Script qualified as R
+
+import Data.Map.Strict qualified as M
+import PlutusTx.Code
+
+defaultValidatorsWithCodes :: M.Map String (ConstitutionValidator, CompiledCode ConstitutionValidator)
+defaultValidatorsWithCodes =
+    [ ("sorted", (S.defaultConstitutionValidator, S.defaultConstitutionCode))
+    , ("unsorted", (U.defaultConstitutionValidator, U.defaultConstitutionCode))
+    -- Disabled, 7 tests fail
+    -- , ("ref", (R.constitutionScript, R.compiledConstitutionScript))
+    ]
+
+defaultValidators :: M.Map String ConstitutionValidator
+defaultValidators = fmap fst defaultValidatorsWithCodes

cardano-constitution/src/Cardano/Constitution/Validator/Data/Common.hs

@@ -0,0 +1,91 @@
+-- editorconfig-checker-disable-file
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Strict            #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE ViewPatterns      #-}
+module Cardano.Constitution.Validator.Data.Common
+    ( withChangedParams
+    , ChangedParams
+    , ConstitutionValidator
+    , validateParamValue
+    ) where
+
+import Cardano.Constitution.Config
+import Data.Coerce
+import PlutusLedgerApi.Data.V3
+import PlutusTx.Builtins qualified as B
+import PlutusTx.Builtins.Internal qualified as BI
+import PlutusTx.NonCanonicalRational as NCRatio
+import PlutusTx.Prelude as Tx hiding (toList)
+
+type ConstitutionValidator = ScriptContext -- ^ Deep inside is the changed-parameters proposal
+                           -> BuiltinUnit -- ^ No-error means the proposal conforms to the constitution
+
+-- OPTIMIZE: operate on BuiltinList<BuiltinPair> directly, needs major refactoring of sorted&unsorted Validators
+type ChangedParams = [(BuiltinData, BuiltinData)]
+
+{- HLINT ignore "Redundant lambda" -} -- I like to see until where it supposed to be first applied.
+{- HLINT ignore "Collapse lambdas" -} -- I like to see and comment on each arg
+withChangedParams :: (ChangedParams -> Bool) -> ConstitutionValidator
+withChangedParams fun (scriptContextToValidGovAction -> validGovAction) =
+    case validGovAction of
+        Just cparams ->  if fun cparams
+            then BI.unitval
+            else traceError "ChangedParams failed to validate"
+        Nothing -> BI.unitval -- this is a treasury withdrawal, we just accept it
+{-# INLINABLE withChangedParams #-}
+
+validateParamValue :: ParamValue -> BuiltinData -> Bool
+validateParamValue = \case
+    ParamInteger preds -> validatePreds preds . B.unsafeDataAsI
+    ParamRational preds -> validatePreds preds . coerce . unsafeFromBuiltinData @NonCanonicalRational
+    ParamList paramValues -> validateParamValues paramValues . BI.unsafeDataAsList
+    -- accept the actual proposed value without examining it
+    ParamAny -> const True
+  where
+      validateParamValues :: [ParamValue] -> BI.BuiltinList BuiltinData -> Bool
+      validateParamValues = \case
+          (paramValueHd : paramValueTl) -> \actualValueData ->
+              -- if actualValueData is not a cons, it will error
+              validateParamValue paramValueHd (BI.head actualValueData)
+              && validateParamValues paramValueTl (BI.tail actualValueData)
+          -- if reached the end of list of param-values to check, ensure no more proposed data are left
+          [] -> B.fromOpaque . BI.null
+
+      validatePreds :: forall a. Tx.Ord a => Predicates a -> a -> Bool
+      validatePreds (Predicates preds) (validatePred -> validatePredAppliedToActual) =
+          Tx.all validatePredAppliedToActual preds
+
+      validatePred :: forall a. Tx.Ord a => a -> Predicate a -> Bool
+      validatePred actualValue (predKey, expectedPredValues) =
+          Tx.all meaningWithActual expectedPredValues
+        where
+          -- we find the meaning (function) from the PredKey
+          meaning = defaultPredMeanings predKey
+          -- apply the meaning to actual value: expectedValue is 1st argument, actualValue is 2nd argument
+          meaningWithActual = (`meaning` actualValue)
+{-# INLINABLE validateParamValue #-}
+
+scriptContextToValidGovAction :: ScriptContext-> Maybe ChangedParams
+scriptContextToValidGovAction =
+    governanceActionToValidGovAction
+    . ppGovernanceAction
+    . scriptInfoToProposalProcedure
+    . scriptContextScriptInfo
+
+  where
+    scriptInfoToProposalProcedure :: ScriptInfo -> ProposalProcedure
+    scriptInfoToProposalProcedure si =
+        case si of
+            (ProposingScript _ pp) -> pp
+            _ -> traceError "Not a ProposalProcedure. This should not ever happen, because ledger should guard before, against it."
+
+    governanceActionToValidGovAction :: GovernanceAction -> Maybe ChangedParams
+    governanceActionToValidGovAction govAction =
+        case govAction of
+            (ParameterChange _ cparams _) -> Just . B.unsafeDataAsMap . toBuiltinData $ cparams
+            (TreasuryWithdrawals _ _) -> Nothing
+            _ -> traceError "Not a ChangedParams. This should not ever happen, because ledger should guard before, against it."
+{-# INLINABLE scriptContextToValidGovAction #-}

cardano-constitution/src/Cardano/Constitution/Validator/Data/Sorted.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE Strict            #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE ViewPatterns      #-}
+-- Following is for tx compilation
+{-# LANGUAGE DataKinds         #-}
+{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+
+module Cardano.Constitution.Validator.Data.Sorted
+    ( constitutionValidator
+    , defaultConstitutionValidator
+    , mkConstitutionCode
+    , defaultConstitutionCode
+    ) where
+
+import Cardano.Constitution.Config
+import Cardano.Constitution.Validator.Data.Common as Common
+import PlutusCore.Version (plcVersion110)
+import PlutusTx as Tx
+import PlutusTx.Builtins as B
+import PlutusTx.Prelude as Tx
+
+-- | Expects a constitution-configuration, statically *OR* at runtime via Tx.liftCode
+constitutionValidator :: ConstitutionConfig -> ConstitutionValidator
+constitutionValidator (ConstitutionConfig cfg) =
+    Common.withChangedParams (runRules cfg)
+
+-- | The `runRules` is a loop that works element-wise from left-to-right on the 2 sorted maps.
+runRules :: [Param]  -- ^ the config (sorted by default)
+         -> ChangedParams -- ^ the params (came sorted by the ledger)
+         -> Bool
+runRules ((expectedPid, paramValue) : cfgRest)
+         cparams@((B.unsafeDataAsI -> actualPid, actualValueData) : cparamsRest) =
+    case actualPid `compare` expectedPid of
+        EQ ->
+            Common.validateParamValue paramValue actualValueData
+            -- drop both heads, and continue checking the next changed param
+            && runRules cfgRest cparamsRest
+
+        GT -> -- skip configHead pointing to a parameter not being proposed
+            runRules cfgRest cparams
+        LT -> -- actualPid not found in json config, the constitution fails
+            False
+-- if no cparams left: success
+-- if cparams left: it means we reached the end of config without validating all cparams
+runRules _ cparams = Tx.null cparams
+
+-- | Statically configure the validator with the `defaultConstitutionConfig`.
+defaultConstitutionValidator :: ConstitutionValidator
+defaultConstitutionValidator = constitutionValidator defaultConstitutionConfig
+
+{-| Make a constitution code by supplied the config at runtime.
+
+See Note [Manually constructing a Configuration value]
+-}
+mkConstitutionCode :: ConstitutionConfig -> CompiledCode ConstitutionValidator
+mkConstitutionCode cCfg = $$(compile [|| constitutionValidator ||])
+                          `unsafeApplyCode` liftCode plcVersion110 cCfg
+
+-- | The code of the constitution statically configured with the `defaultConstitutionConfig`.
+defaultConstitutionCode :: CompiledCode ConstitutionValidator
+defaultConstitutionCode = $$(compile [|| defaultConstitutionValidator ||])

cardano-constitution/src/Cardano/Constitution/Validator/Data/Unsorted.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Strict            #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE ViewPatterns      #-}
+-- Following is for tx compilation
+{-# LANGUAGE DataKinds         #-}
+{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
+
+module Cardano.Constitution.Validator.Data.Unsorted
+    ( constitutionValidator
+    , defaultConstitutionValidator
+    , mkConstitutionCode
+    , defaultConstitutionCode
+    ) where
+
+import Cardano.Constitution.Config
+import Cardano.Constitution.Validator.Data.Common as Common
+import PlutusCore.Version (plcVersion110)
+import PlutusTx as Tx
+import PlutusTx.Builtins as B
+import PlutusTx.Prelude as Tx
+
+-- | Expects a constitution-configuration, statically *OR* at runtime via Tx.liftCode
+constitutionValidator :: ConstitutionConfig -> ConstitutionValidator
+constitutionValidator cfg = Common.withChangedParams
+                            (all (validateParam cfg))
+
+validateParam :: ConstitutionConfig -> (BuiltinData, BuiltinData) -> Bool
+validateParam (ConstitutionConfig cfg) (B.unsafeDataAsI -> actualPid, actualValueData) =
+    Common.validateParamValue
+      -- If param not found, it will error
+      (lookupUnsafe actualPid cfg)
+      actualValueData
+
+-- | An unsafe version of PlutusTx.AssocMap.lookup, specialised to Integer keys
+lookupUnsafe :: Integer -> [(Integer, v)] -> v
+lookupUnsafe k = go
+ where
+   go [] = traceError "Unsorted lookup failed"
+   go ((k', i) : xs') = if k `B.equalsInteger` k'
+                        then i
+                        else go xs'
+{-# INLINEABLE lookupUnsafe #-}
+
+-- | Statically configure the validator with the `defaultConstitutionConfig`.
+defaultConstitutionValidator :: ConstitutionValidator
+defaultConstitutionValidator = constitutionValidator defaultConstitutionConfig
+
+{-| Make a constitution code by supplied the config at runtime.
+
+See Note [Manually constructing a Configuration value]
+-}
+mkConstitutionCode :: ConstitutionConfig -> CompiledCode ConstitutionValidator
+mkConstitutionCode cCfg = $$(compile [|| constitutionValidator ||])
+                          `unsafeApplyCode` liftCode plcVersion110 cCfg
+
+-- | The code of the constitution statically configured with the `defaultConstitutionConfig`.
+defaultConstitutionCode :: CompiledCode ConstitutionValidator
+defaultConstitutionCode = $$(compile [|| defaultConstitutionValidator ||])

cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests.hs

@@ -0,0 +1,93 @@
+-- editorconfig-checker-disable-file
+module Cardano.Constitution.Validator.Data.GoldenTests
+    ( tests
+    ) where
+
+import Cardano.Constitution.Config
+import Cardano.Constitution.Data.Validator
+import Cardano.Constitution.Validator.TestsCommon
+import Helpers.TestBuilders
+import PlutusCore.Evaluation.Machine.ExBudget
+import PlutusCore.Evaluation.Machine.ExBudgetingDefaults
+import PlutusCore.Pretty (prettyPlcReadableSimple)
+import PlutusLedgerApi.V3 as V3
+import PlutusLedgerApi.V3.ArbitraryContexts as V3
+import PlutusTx.Code as Tx
+import UntypedPlutusCore as UPLC
+import UntypedPlutusCore.Evaluation.Machine.Cek as UPLC
+
+import Data.ByteString.Short qualified as SBS
+import Data.Map.Strict qualified as M
+import Data.Maybe
+import Data.String
+import System.FilePath
+import Test.Tasty
+import Test.Tasty.Golden
+
+import Helpers.Guardrail
+
+-- The golden files may change, so use `--accept` in cabal `--test-options` to accept the changes **after reviewing them**.
+
+test_cbor, test_budget_small, test_budget_large, test_readable_pir, test_readable_uplc :: TestTree
+
+test_cbor = testGroup "Cbor" $ M.elems $
+    (\vName (_, vCode) ->
+         -- The unit of measurement is in bytes
+         goldenVsString vName (mkPath vName ["cbor","size"]) $
+            pure $ fromString $ show $ SBS.length $ V3.serialiseCompiledCode vCode
+    ) `M.mapWithKey` defaultValidatorsWithCodes
+
+test_budget_large = testGroup "BudgetLarge" $ M.elems $
+    (\vName (_, vCode) ->
+         -- The unit of measurement is in execution steps.
+         -- See maxTxExSteps, maxTxExMem for limits for chain limits: <https://beta.explorer.cardano.org/en/protocol-parameters/>
+         goldenVsString vName (mkPath vName ["large","budget"]) $
+            pure $ fromString $ show $ runForBudget vCode $ V3.mkFakeParameterChangeContext getFakeLargeParamsChange -- mkLargeFakeProposal defaultConstitutionConfig
+    )`M.mapWithKey` defaultValidatorsWithCodes
+
+test_budget_small = testGroup "BudgetSmall" $ M.elems $
+    (\vName (_, vCode) ->
+         -- The unit of measurement is in execution steps.
+         -- See maxTxExSteps, maxTxExMem for limits for chain limits: <https://beta.explorer.cardano.org/en/protocol-parameters/>
+         goldenVsString vName (mkPath vName ["small","budget"]) $
+            pure $ fromString $ show $ runForBudget vCode $ V3.mkSmallFakeProposal defaultConstitutionConfig
+    )`M.mapWithKey` defaultValidatorsWithCodes
+
+test_readable_pir = testGroup "ReadablePir" $ M.elems $
+    (\vName (_, vCode) ->
+         goldenVsString vName (mkPath vName ["pir"]) $
+            pure $ fromString $ show $ prettyPlcReadableSimple $ fromJust $ getPirNoAnn vCode
+    )`M.mapWithKey` defaultValidatorsWithCodes
+
+test_readable_uplc = testGroup "ReadableUplc" $ M.elems $
+    (\vName (_, vCode) ->
+         goldenVsString vName (mkPath vName ["uplc"]) $
+            pure $ fromString $ show $ prettyPlcReadableSimple $ getPlcNoAnn vCode
+    )`M.mapWithKey` defaultValidatorsWithCodes
+
+tests :: TestTreeWithTestState
+tests = testGroup' "Golden" $ fmap const
+        [ test_cbor
+        , test_budget_large
+        , test_budget_small
+        , test_readable_pir
+        , test_readable_uplc
+        ]
+
+-- HELPERS
+
+mkPath :: String -> [String] -> FilePath
+mkPath vName exts = foldl1 (</>) ["test","Cardano","Constitution","Validator","Data","GoldenTests", foldl (<.>) vName (exts++["golden"])]
+
+runForBudget :: (ToData ctx)
+             => CompiledCode ConstitutionValidator
+             -> ctx
+             -> ExBudget
+runForBudget v ctx =
+        let vPs = UPLC._progTerm $ getPlcNoAnn $ v
+                  `unsafeApplyCode` liftCode110 (unsafeFromBuiltinData . toBuiltinData $ ctx)
+        in case UPLC.runCekDeBruijn defaultCekParametersForTesting counting noEmitter vPs of
+                -- Here, we guard against the case that a ConstitutionValidator **FAILS EARLY** (for some reason),
+                -- resulting in misleading low budget costs.
+                (Left _, _, _) -> error "For safety, we only compare budget of succesful executions."
+                (Right _ , UPLC.CountingSt budget, _) -> budget

cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests/sorted.cbor.size.golden

@@ -0,0 +1 @@
+2325

cardano-constitution/test/Cardano/Constitution/Validator/Data/GoldenTests/sorted.large.budget.golden

@@ -0,0 +1 @@
+ExBudget {exBudgetCPU = ExCPU 610267640, exBudgetMemory = ExMemory 3014102}