Fix validator evaluation -> force evaluation of the computation.

cardano-scaling · Jan 5, 2022 · 53eab8e · 53eab8e
1 parent 26a6edf
commit 53eab8e
Show file tree

Hide file tree

Showing 3 changed files with 33 additions and 27 deletions.
diff --git a/plutus-cbor/src/Plutus/Codec/CBOR/Encoding.hs b/plutus-cbor/src/Plutus/Codec/CBOR/Encoding.hs
@@ -1,16 +1,13 @@
 module Plutus.Codec.CBOR.Encoding (
-  -- * Encoding
   Encoding,
   encodingToBuiltinByteString,
-
-  -- * Basic types
   encodeInteger,
-
-  -- * Data-structures
 ) where
 
 import PlutusTx.Prelude
 
+import PlutusTx.Builtins (subtractInteger)
+
 -- * Encoding
 
 type Encoding = BuiltinByteString
@@ -24,7 +21,7 @@ encodingToBuiltinByteString = id
 encodeInteger :: Integer -> Encoding
 encodeInteger n
   | n < 0 =
-    encodeUnsigned 1 (-n - 1)
+    encodeUnsigned 1 (subtractInteger 0 n - 1)
   | otherwise =
     encodeUnsigned 0 n
 {-# INLINEABLE encodeInteger #-}

diff --git a/plutus-cbor/test/Plutus/Codec/CBOR/EncodingSpec.hs b/plutus-cbor/test/Plutus/Codec/CBOR/EncodingSpec.hs
@@ -12,6 +12,7 @@ import qualified Codec.CBOR.Pretty as CBOR
 import qualified Codec.CBOR.Write as CBOR
 import Data.Binary.Builder (toLazyByteString)
 import Data.ByteArray (convert)
+import qualified Data.ByteString as BS
 import Data.ByteString.Base16 (encodeBase16)
 import Data.ByteString.Builder.Scientific (FPFormat (Fixed), formatScientificBuilder)
 import Data.Ratio ((%))
@@ -34,12 +35,12 @@ import Test.Plutus.Codec.CBOR.Encoding.Validators (
 import Test.QuickCheck (
   Property,
   choose,
+  conjoin,
   counterexample,
   forAll,
   forAllBlind,
+  label,
   oneof,
-  vectorOf,
-  (.&&.),
   (===),
  )
 
@@ -51,9 +52,12 @@ spec = do
         propCompareWithOracle CBOR.encodeInteger encodeInteger
 
   describe "(on-chain) execution cost of CBOR encoding is small" $ do
-    prop "for all (x :: Integer), <0.05%" $
-      forAllBlind (vectorOf 100 genInteger) $
-        propCostIsSmall (1 % 2_000) defaultMaxExecutionUnits encodeIntegerValidator
+    prop "for all (x :: Integer), <0.5%" $
+      forAllBlind genInteger $
+        propCostIsSmall
+          (1 % 200)
+          defaultMaxExecutionUnits
+          (encodeInteger, encodeIntegerValidator)
 
 -- | Compare encoding a value 'x' with our own encoder and a reference
 -- implementation. Counterexamples shows both encoded values, but in a pretty /
@@ -80,11 +84,15 @@ propCostIsSmall ::
   Plutus.ToData a =>
   Rational ->
   ExUnits ->
-  Scripts.TypedValidator (EncodeValidator a) ->
-  [a] ->
+  (a -> Encoding, Scripts.TypedValidator (EncodeValidator a)) ->
+  a ->
   Property
-propCostIsSmall tolerance (ExUnits maxMemUnits maxStepsUnits) encode xs =
-  ((relativeMemCost < tolerance) .&&. (relativeStepCost < tolerance))
+propCostIsSmall tolerance (ExUnits maxMemUnits maxStepsUnits) (encode, validator) a =
+  conjoin
+    [ relativeMemCost < tolerance
+    , relativeStepCost < tolerance
+    ]
+    & label ("of size = " <> show n <> ", mem units = " <> show mem <> ", CPU units = " <> show steps)
     & counterexample
       ( "memory execution units: "
           <> show mem
@@ -100,13 +108,11 @@ propCostIsSmall tolerance (ExUnits maxMemUnits maxStepsUnits) encode xs =
           <> ")"
       )
  where
-  n = fromIntegral (length xs)
-
+  n = BS.length $ convert $ encode a
   ExUnits mem steps =
     distanceExUnits
       (evaluateScriptExecutionUnits emptyValidator ())
-      (evaluateScriptExecutionUnits encode xs)
-      & (\(ExUnits m s) -> ExUnits (m `div` n) (s `div` n))
+      (evaluateScriptExecutionUnits validator a)
 
   (relativeMemCost, relativeStepCost) =
     ( toInteger mem % toInteger maxMemUnits

diff --git a/plutus-cbor/test/Test/Plutus/Codec/CBOR/Encoding/Validators.hs b/plutus-cbor/test/Test/Plutus/Codec/CBOR/Encoding/Validators.hs
@@ -4,12 +4,10 @@
 
 module Test.Plutus.Codec.CBOR.Encoding.Validators where
 
-import Hydra.Prelude hiding (label)
+import PlutusTx.Prelude
 
 import qualified Ledger.Typed.Scripts as Scripts
-import Plutus.Codec.CBOR.Encoding (
-  encodeInteger,
- )
+import Plutus.Codec.CBOR.Encoding (encodeInteger)
 import qualified PlutusTx as Plutus
 
 -- | A baseline validator which does nothing but returning 'True'. We use it as
@@ -23,7 +21,7 @@ instance Scripts.ValidatorTypes EmptyValidator where
 emptyValidator :: Scripts.TypedValidator EmptyValidator
 emptyValidator =
   Scripts.mkTypedValidator @EmptyValidator
-    $$(Plutus.compile [||\() () _ctx -> True||])
+    $$(Plutus.compile [||\() () _ctx -> lengthOfByteString "" == 0||])
     $$(Plutus.compile [||wrap||])
  where
   wrap = Scripts.wrapValidator @() @()
@@ -34,12 +32,17 @@ data EncodeValidator a
 
 instance Scripts.ValidatorTypes (EncodeValidator a) where
   type DatumType (EncodeValidator a) = ()
-  type RedeemerType (EncodeValidator a) = [a]
+  type RedeemerType (EncodeValidator a) = a
 
 encodeIntegerValidator :: Scripts.TypedValidator (EncodeValidator Integer)
 encodeIntegerValidator =
   Scripts.mkTypedValidator @(EncodeValidator Integer)
-    $$(Plutus.compile [||\() xs _ctx -> let _bytes = encodeInteger <$> xs in True||])
+    $$( Plutus.compile
+          [||
+          \() a _ctx ->
+            lengthOfByteString (encodeInteger a) > 0
+          ||]
+      )
     $$(Plutus.compile [||wrap||])
  where
-  wrap = Scripts.wrapValidator @() @[Integer]
+  wrap = Scripts.wrapValidator @() @Integer