sorting out commented tests, homogenizing test names and fixing false…

… validator issue
tweag · Mar 20, 2024 · d86c2fd · d86c2fd
1 parent c064a94
commit d86c2fd
Show file tree

Hide file tree

Showing 6 changed files with 36 additions and 77 deletions.
diff --git a/src/Cooked/Validators.hs b/src/Cooked/Validators.hs
@@ -1,7 +1,5 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 
 -- | This module introduces standard dummy validators to be used in
@@ -23,17 +21,17 @@ import qualified PlutusTx as Pl
 -- a sufficient target for the datum hijacking attack since we only
 -- want to show feasibility of the attack.
 alwaysTrueValidator :: Pl.TypedValidator a
-alwaysTrueValidator = unsafeTypedValidatorFromUPLC (Pl.getPlc $$(Pl.compile [||tgt||]))
+alwaysTrueValidator = unsafeTypedValidatorFromUPLC $ Pl.getPlc $$(Pl.compile [||tgt||])
   where
-    tgt :: Pl.BuiltinData -> Pl.BuiltinData -> Pl.BuiltinData -> ()
-    tgt _ _ _ = ()
+    tgt :: Pl.BuiltinData -> Pl.BuiltinData -> Pl.BuiltinData -> Bool
+    tgt _ _ _ = True
 
 -- | The trivial validator that always fails
 alwaysFalseValidator :: Pl.TypedValidator a
-alwaysFalseValidator = unsafeTypedValidatorFromUPLC (Pl.getPlc $$(Pl.compile [||tgt||]))
+alwaysFalseValidator = unsafeTypedValidatorFromUPLC $ Pl.getPlc $$(Pl.compile [||tgt||])
   where
-    tgt :: Pl.BuiltinData -> Pl.BuiltinData -> Pl.BuiltinData -> ()
-    tgt _ _ _ = error "This validator always fails."
+    tgt :: Pl.BuiltinData -> Pl.BuiltinData -> Pl.BuiltinData -> Bool
+    tgt _ _ _ = False
 
 -- | A Mock contract type to instantiate validators with
 data MockContract

diff --git a/tests/Cooked/InitialDistributionSpec.hs b/tests/Cooked/InitialDistributionSpec.hs
@@ -61,7 +61,7 @@ spendReferenceAlwaysTrueValidator = do
 tests :: TestTree
 tests =
   testGroup
-    "initial distributions"
+    "Initial distributions"
     [ testCase "Reading datums placed in the initial distribution, inlined, hashed or vanilla" $
         testSucceedsFrom' def (\results _ -> testBool $ results == [10, 10, 10]) initialDistributionWithDatum getValueFromInitialDatum,
       testCase "Spending a script placed as a reference script in the initial distribution" $

diff --git a/tests/Cooked/MinAdaSpec.hs b/tests/Cooked/MinAdaSpec.hs
@@ -50,7 +50,7 @@ paymentWithoutMinAda paidLovelaces = do
 tests :: TestTree
 tests =
   testGroup
-    "automatic minAda adjustment of transaction outputs"
+    "MinAda auto adjustment of transaction outputs"
     [ testCase "adjusted transaction passes" $ testSucceeds def paymentWithMinAda,
       testCase "adjusted transaction contains minimal amount"
         $ testFails

diff --git a/tests/Cooked/ReferenceScriptsSpec.hs b/tests/Cooked/ReferenceScriptsSpec.hs
@@ -28,30 +28,6 @@ import qualified Prettyprinter as PP
 import Test.Tasty
 import Test.Tasty.HUnit
 
--- | The validator that always agrees to the transaction
-yesValidator :: Pl.TypedValidator MockContract
-yesValidator =
-  Pl.mkTypedValidator @MockContract
-    $$(Pl.compile [||val||])
-    $$(Pl.compile [||wrap||])
-  where
-    val :: () -> () -> Pl.ScriptContext -> Bool
-    val _ _ _ = True
-
-    wrap = Pl.mkUntypedValidator
-
--- | The validator that never agrees to the transaction
-noValidator :: Pl.TypedValidator MockContract
-noValidator =
-  Pl.mkTypedValidator @MockContract
-    $$(Pl.compile [||val||])
-    $$(Pl.compile [||wrap||])
-  where
-    val :: () -> () -> Pl.ScriptContext -> Bool
-    val _ _ _ = False
-
-    wrap = Pl.mkUntypedValidator
-
 -- | This validator ensures that the given public key signs the transaction.
 requireSignerValidator :: Pl.PubKeyHash -> Pl.TypedValidator MockContract
 requireSignerValidator =
@@ -182,9 +158,9 @@ useReferenceScript spendingSubmitter theScript = do
 tests :: TestTree
 tests =
   testGroup
-    "reference scripts"
+    "Reference scripts"
     [ testGroup "putting reference scripts on chain and retreiving them" $
-        let theRefScript = noValidator
+        let theRefScript = alwaysFalseValidator
             theRefScriptHash = toScriptHash theRefScript
          in [ testCase "on a public key output"
                 $ testSucceedsFrom'
@@ -204,7 +180,7 @@ tests =
                         Just theRefScriptHash .==. mScriptHash
                   )
                   def
-                $ putRefScriptOnScriptOutput yesValidator theRefScript
+                $ putRefScriptOnScriptOutput alwaysTrueValidator theRefScript
                   >>= retrieveRefScriptHash,
               testCase "retreiving the complete script from its hash"
                 $ testSucceedsFrom'
@@ -227,12 +203,12 @@ tests =
                   def
                   (== "there is no reference input with the correct script hash")
               )
-            $ putRefScriptOnWalletOutput (wallet 3) noValidator
-              >>= checkReferenceScriptOnOref (toScriptHash yesValidator),
+            $ putRefScriptOnWalletOutput (wallet 3) alwaysFalseValidator
+              >>= checkReferenceScriptOnOref (toScriptHash alwaysTrueValidator),
           testCase "succeed if correct reference script" $
             testSucceeds def $
-              putRefScriptOnWalletOutput (wallet 3) yesValidator
-                >>= checkReferenceScriptOnOref (toScriptHash yesValidator)
+              putRefScriptOnWalletOutput (wallet 3) alwaysTrueValidator
+                >>= checkReferenceScriptOnOref (toScriptHash alwaysTrueValidator)
         ],
       testGroup
         "using reference scripts"
@@ -256,7 +232,7 @@ tests =
                     txSkelTemplate
                       { txSkelOuts =
                           [ paysScript
-                              yesValidator
+                              (alwaysTrueValidator @MockContract)
                               ()
                               (Pl.lovelaceValueOf 42_000_000)
                           ],
@@ -280,14 +256,14 @@ tests =
                   )
                   def
                   $ do
-                    scriptOref <- putRefScriptOnWalletOutput (wallet 3) noValidator
+                    scriptOref <- putRefScriptOnWalletOutput (wallet 3) alwaysFalseValidator
                     (oref, _) : _ <-
                       utxosFromCardanoTx
                         <$> validateTxSkel
                           txSkelTemplate
                             { txSkelOuts =
                                 [ paysScript
-                                    yesValidator
+                                    (alwaysTrueValidator @MockContract)
                                     ()
                                     (Pl.lovelaceValueOf 42_000_000)
                                 ],
@@ -309,14 +285,14 @@ tests =
               )
               def
             $ do
-              scriptOref <- putRefScriptOnWalletOutput (wallet 3) yesValidator
+              scriptOref <- putRefScriptOnWalletOutput (wallet 3) alwaysTrueValidator
               (oref, _) : _ <-
                 utxosFromCardanoTx
                   <$> validateTxSkel
                     txSkelTemplate
                       { txSkelOuts =
                           [ paysScript
-                              yesValidator
+                              (alwaysTrueValidator @MockContract)
                               ()
                               (Pl.lovelaceValueOf 42_000_000)
                           ],

diff --git a/tests/Cooked/ShowBSSpec.hs b/tests/Cooked/ShowBSSpec.hs
@@ -65,7 +65,7 @@ printTrace = do
 tests :: TestTree
 tests =
   testGroup
-    "printing to BuiltinString"
+    "BuiltinString serializing"
     [ testCase "a few simple examples" $
         testConjoin $
           map

diff --git a/tests/Spec.hs b/tests/Spec.hs
@@ -1,6 +1,4 @@
 import qualified Cooked.AttackSpec as AttackSpec
--- import qualified Cooked.BalanceSpec as Ba
-
 import qualified Cooked.InitialDistributionSpec as InitDistrib
 import qualified Cooked.InlineDatumsSpec as InlineDatumsSpec
 import qualified Cooked.LtlSpec as LtlSpec
@@ -10,34 +8,21 @@ import qualified Cooked.ReferenceInputsSpec as ReferenceInputsSpec
 import qualified Cooked.ReferenceScriptsSpec as ReferenceScriptsSpec
 import qualified Cooked.ShowBSSpec as ShowBSSpec
 import qualified Cooked.TweakSpec as TweakSpec
--- import qualified Cooked.MockChain.Monad.StagedSpec as StagedSpec
--- import qualified Cooked.MockChain.UtxoStateSpec as UtxoStateSpec
--- import qualified Cooked.WalletSpec as WalletSpec
--- import qualified Cooked.OutputReorderingSpec as OutputReorderingSpec
--- import qualified Cooked.QuickValueSpec as QuickValueSpec
 import Test.Tasty
 
 main :: IO ()
-main = defaultMain tests
-
-tests :: TestTree
-tests =
-  testGroup
-    "cooked-validators"
-    [ -- testGroup "Reordering outputs" OutputReorderingSpec.tests,
-      -- testGroup "Balancing transactions" Ba.tests,
-      -- testGroup "Quick values" QuickValueSpec.tests,
-      -- testGroup "Staged monad" StagedSpec.tests,
-      -- testGroup "UtxoState" UtxoStateSpec.tests,
-      -- testGroup "Wallet" WalletSpec.tests,
-      MinAdaSpec.tests,
-      InlineDatumsSpec.tests,
-      ReferenceInputsSpec.tests,
-      ReferenceScriptsSpec.tests,
-      AttackSpec.tests,
-      TweakSpec.tests,
-      LtlSpec.tests,
-      MockChainSpec.tests,
-      ShowBSSpec.tests,
-      InitDistrib.tests
-    ]
+main =
+  defaultMain $
+    testGroup
+      "cooked-validators"
+      [ MinAdaSpec.tests,
+        InlineDatumsSpec.tests,
+        ReferenceInputsSpec.tests,
+        ReferenceScriptsSpec.tests,
+        AttackSpec.tests,
+        TweakSpec.tests,
+        LtlSpec.tests,
+        MockChainSpec.tests,
+        ShowBSSpec.tests,
+        InitDistrib.tests
+      ]