test: wip: add foundation for property testing

Author: errfrom

Makefile

@@ -1,11 +1,14 @@
-.PHONY: build, repl, format, hoogle, all_scripts, auction_metadata_validator, standing_bid_validator
+.PHONY: build test repl format hoogle all_scripts auction_metadata_validator standing_bid_validator
 
 hs-sources := $(shell fd --no-ignore-parent -ehs)
 cabal-sources := $(shell fd --no-ignore-parent -ecabal)
 
 build:
 	cabal v2-build all
 
+test:
+	cabal v2-test
+
 repl:
 	cabal v2-repl hydra-auction-onchain --ghc-options '-Wno-missing-import-lists'
 

hydra-auction-onchain.cabal

@@ -147,3 +147,24 @@ executable hydra-auction-onchain-exe
   other-modules:
   hs-source-dirs: app
   ghc-options:    -threaded -rtsopts -with-rtsopts=-N
+
+test-suite hydra-auction-onchain-test
+  import:         common-lang
+  type:           exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is:        Spec.hs
+  other-modules:
+    Spec.HydraAuctionOnchain.Helpers
+    Spec.HydraAuctionOnchain.Types.AuctionTerms
+    Spec.HydraAuctionOnchain.Validators.StandingBid
+
+  build-depends:
+    , hydra-auction-onchain
+    , plutarch
+    , plutus-ledger-api
+    , plutus-tx
+    , pretty-simple
+    , QuickCheck
+    , tasty
+    , tasty-quickcheck
+    , text

src/HydraAuctionOnchain/Scripts.hs

@@ -1,6 +1,7 @@
 module HydraAuctionOnchain.Scripts
   ( auctionMetadataValidatorScript
   , auctionMetadataValidatorUntyped
+  , compileScript
   , standingBidValidatorScript
   , standingBidValidatorUntyped
   , writeScript

test/Spec.hs

@@ -0,0 +1,12 @@
+module Main (main) where
+
+import Spec.HydraAuctionOnchain.Validators.StandingBid qualified as StandingBid (spec)
+import Test.Tasty (defaultMain, testGroup)
+
+main :: IO ()
+main =
+  defaultMain $
+    testGroup
+      "hydra-auction-onchain"
+      [ StandingBid.spec
+      ]

test/Spec/HydraAuctionOnchain/Helpers.hs

@@ -0,0 +1,26 @@
+module Spec.HydraAuctionOnchain.Helpers
+  ( shouldFail
+  ) where
+
+import Data.Text.Lazy qualified as TL (unpack)
+import Plutarch (Script)
+import Plutarch.Evaluate (evalScript)
+import Test.Tasty.QuickCheck (Property, counterexample, property)
+import Text.Pretty.Simple (pShow)
+
+shouldFail :: Script -> Property
+shouldFail script =
+  case result of
+    Left _ -> property True
+    Right _ ->
+      counterexample "Expected failure, but succeeded instead."
+        . counterexample (showLogs logs)
+        . property
+        $ False
+  where
+    (result, _exUnits, logs) = evalScript script
+
+showLogs :: Show a => [a] -> String
+showLogs = \case
+  [] -> "No logs found. Did you forget to compile with tracing on?"
+  logs -> TL.unpack $ pShow logs

test/Spec/HydraAuctionOnchain/Types/AuctionTerms.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Spec.HydraAuctionOnchain.Types.AuctionTerms
+  ( AuctionTerms (..)
+  ) where
+
+import HydraAuctionOnchain.Types.AuctionTerms (PAuctionTerms)
+import Plutarch.DataRepr (DerivePConstantViaData (DerivePConstantViaData))
+import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
+import PlutusLedgerApi.V2 (BuiltinByteString, POSIXTime, PubKeyHash, Value)
+import PlutusTx (makeIsDataIndexed)
+
+data AuctionTerms = AuctionTerms
+  { at'AuctionLot :: Value
+  , at'SellerPkh :: PubKeyHash
+  , at'SellerVk :: BuiltinByteString
+  , at'Delegates :: [PubKeyHash]
+  , at'BiddingStart :: POSIXTime
+  , at'BiddingEnd :: POSIXTime
+  , at'PurchaseDeadline :: POSIXTime
+  , at'Cleanup :: POSIXTime
+  , at'AuctionFeePerDelegate :: Integer
+  , at'StartingBid :: Integer
+  , at'MinBidIncrement :: Integer
+  , at'MinDepositAmount :: Integer
+  }
+  deriving stock (Show, Eq)
+
+makeIsDataIndexed ''AuctionTerms [('AuctionTerms, 0)]
+
+deriving via
+  (DerivePConstantViaData AuctionTerms PAuctionTerms)
+  instance
+    (PConstantDecl AuctionTerms)
+
+instance PUnsafeLiftDecl PAuctionTerms where
+  type PLifted PAuctionTerms = AuctionTerms

test/Spec/HydraAuctionOnchain/Validators/StandingBid.hs

@@ -0,0 +1,36 @@
+module Spec.HydraAuctionOnchain.Validators.StandingBid (spec) where
+
+import HydraAuctionOnchain.Scripts (compileScript)
+import HydraAuctionOnchain.Validators.StandingBid (standingBidValidator)
+import Plutarch (Script)
+import PlutusLedgerApi.V2 (CurrencySymbol, ScriptContext)
+import Spec.HydraAuctionOnchain.Helpers (shouldFail)
+import Spec.HydraAuctionOnchain.Types.AuctionTerms (AuctionTerms)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.QuickCheck (Property, testProperty)
+
+spec :: TestTree
+spec =
+  testGroup
+    "StandingBid"
+    [ testProperty "Fails when own input is missing" prop_ownInputMissing_fails
+    ]
+
+prop_ownInputMissing_fails :: Property
+prop_ownInputMissing_fails = shouldFail undefined
+
+compile
+  :: CurrencySymbol
+  -> AuctionTerms
+  -> StandingBidState
+  -> StandingBidRedeemer
+  -> ScriptContext
+  -> Script
+compile auctionCs auctionTerms datum redeemer =
+  compileScript $
+    popaque $
+      standingBidValidator
+        # pconstant auctionCs
+        # pconstant auctionTerms
+        # pconstant datum
+        # pconstant redeemer