test(ping-pong): unit tests over the contract

bogdan-manole · bogdan-manole · commit e3585bb2d556 · 2025-12-15T13:13:20.000+02:00
diff --git a/src/coin-selection/test/Scripts.hs b/src/coin-selection/test/Scripts.hs
@@ -18,12 +18,13 @@ module Scripts (
   sampleValidatorScript,
   pingPongValidatorScript,
   spendSample,
-  spendPingPong,
+  playPingPongRound,
   Sample.SampleRedeemer (..),
   PingPong.PingPongRedeemer (..),
   PingPong.PingPongState (..),
 ) where
 
+import Cardano.Api (NetworkId)
 import Cardano.Api qualified as C
 import Convex.BuildTx (MonadBuildTx)
 import Convex.BuildTx qualified as BuildTx
@@ -124,19 +125,36 @@ spendSample redeemer txi =
             redeemer
    in BuildTx.setScriptsValid >> BuildTx.addInputWithTxBody txi witness
 
-spendPingPong
+plutusScript :: (C.IsPlutusScriptLanguage lang) => C.PlutusScript lang -> C.Script lang
+plutusScript = C.PlutusScript C.plutusScriptVersion
+
+playPingPongRound
   :: forall era m
-   . (C.IsAlonzoBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV3 era)
+   . ( C.IsBabbageBasedEra era
+     , C.HasScriptLanguageInEra C.PlutusScriptV3 era
+     )
   => (MonadBuildTx era m)
-  => PingPong.PingPongRedeemer
+  => NetworkId
+  -> C.Lovelace
+  -> PingPong.PingPongRedeemer
   -> C.TxIn
   -> m ()
-spendPingPong redeemer txi =
+playPingPongRound networkId value redeemer txi = do
   let witness _ =
         C.ScriptWitness C.ScriptWitnessForSpending $
           BuildTx.buildScriptWitness
             pingPongValidatorScript
             (C.ScriptDatumForTxIn $ Nothing) -- Just $ toHashableScriptData PingPong.Pinged)
             -- (fromIntegral @Int @Integer $ 9898) -- BuildTx.findIndexSpending txi txBody)
             redeemer
-   in BuildTx.setScriptsValid >> BuildTx.addInputWithTxBody txi witness
+  BuildTx.setScriptsValid >> BuildTx.addInputWithTxBody txi witness
+  BuildTx.payToScriptInlineDatum
+    networkId
+    (C.hashScript (plutusScript Scripts.pingPongValidatorScript))
+    ( case redeemer of
+        PingPong.Ping -> PingPong.Pinged
+        PingPong.Pong -> PingPong.Ponged
+        PingPong.Stop -> PingPong.Stopped
+    )
+    C.NoStakeAddress
+    (C.lovelaceToValue value) -- add to the witness the datum
diff --git a/src/coin-selection/test/Scripts/PingPong.hs b/src/coin-selection/test/Scripts/PingPong.hs
@@ -8,7 +8,6 @@
 -- A plutus validator that only succeeds if the redeemer is identical to the script's input index
 module Scripts.PingPong (
   validator,
-  validatorSimplified,
   PingPongRedeemer (..),
   PingPongState (..),
 ) where
@@ -21,8 +20,8 @@ import PlutusLedgerApi.V3.Contexts (
   TxInInfo (TxInInfo, txInInfoResolved),
   TxInfo (..),
  )
-import PlutusTx (Data (..), unstableMakeIsData)
-import PlutusTx.AssocMap (Map, lookup, toList)
+import PlutusTx (unstableMakeIsData)
+import PlutusTx.AssocMap (Map, lookup)
 import PlutusTx.Builtins.Internal qualified as BI
 import PlutusTx.IsData.Class (UnsafeFromData (unsafeFromBuiltinData))
 import PlutusTx.Prelude (BuiltinData, BuiltinUnit)
@@ -39,10 +38,8 @@ showState Pinged = "Pinged "
 showState Ponged = "Ponged "
 showState Stopped = "Stopped "
 
--- deriving anyclass (ToJSON, FromJSON)
-
 data PingPongRedeemer = Ping | Pong | Stop
-  deriving stock (Haskell.Show)
+  deriving stock (Haskell.Eq, Haskell.Show)
 
 {-# INLINEABLE showAction #-}
 showAction :: PingPongRedeemer -> P.BuiltinString
@@ -82,31 +79,11 @@ validator
     (Ponged, Stop, Stopped) -> BI.unitval
     _ -> P.traceError P.$ "Invalid state transition: " `P.appendString` showState currentState `P.appendString` showAction action `P.appendString` showState nextState
 
-{-# INLINEABLE validatorSimplified #-}
-validatorSimplified :: BuiltinData -> BuiltinUnit
-validatorSimplified
-  ( unsafeFromBuiltinData ->
-      ScriptContext
-        { scriptContextRedeemer = (unsafeFromBuiltinData P.. getRedeemer -> action :: PingPongRedeemer)
-        , scriptContextTxInfo =
-          txInfo@TxInfo
-            { -- txInfoInputs = (getStateFromInputs -> currentState)
-            txInfoOutputs = (getStateFromOutpusts (txInfoData txInfo) -> nextState)
-            }
-        }
-    ) = case (action, nextState) of
-    (Pong, Ponged) -> BI.unitval
-    (Ping, Pinged) -> BI.unitval
-    (Stop, Stopped) -> BI.unitval
-    _ -> P.traceError "Invalid state transition"
-
 {-# INLINEABLE getStateFromInputs #-}
 getStateFromInputs :: Map DatumHash Datum -> [TxInInfo] -> PingPongState
 getStateFromInputs _ [] = P.traceError "No inputs"
 getStateFromInputs txInfoData' (TxInInfo{txInInfoResolved = TxOut{txOutDatum}} : _) = getPingPongState txInfoData' "Datum on input" txOutDatum
 
--- getStateFromInputs _ _ = P.traceError "Multiple inputs"
-
 {-# INLINEABLE getStateFromOutpusts #-}
 getStateFromOutpusts :: Map DatumHash Datum -> [TxOut] -> PingPongState
 getStateFromOutpusts _ [] = P.traceError "No outputs"
@@ -119,17 +96,3 @@ getPingPongState _ errorMsg NoOutputDatum = P.traceError P.$ P.appendString erro
 getPingPongState datumMap errorMsg (OutputDatumHash hash) = case lookup hash datumMap of
   P.Just (unsafeFromBuiltinData P.. getDatum -> state :: PingPongState) -> state
   P.Nothing -> P.traceError P.$ P.appendString errorMsg " - OutputDatumHash not found in datum map"
-
--- getPingPongState errorMsg (OutputDatum datum) =
---   -- let d = getDatum datum
---   P.traceError P.$ errorMsg
-
-{-# INLINEABLE inspectDatum #-}
-inspectDatum :: BuiltinData -> P.BuiltinString
-inspectDatum d =
-  case BI.builtinDataToData d of
-    Constr i _ -> "Constructor " -- `P.appendString` showInt i
-    Map _ -> "Map"
-    List _ -> "List"
-    I _ -> "Integer"
-    B _ -> "ByteString"
diff --git a/src/coin-selection/test/Spec.hs b/src/coin-selection/test/Spec.hs
@@ -150,7 +150,65 @@ tests =
                 -- Test tree fails
                 (\_ -> pure ())
             )
-        , testCase "spend pingPong an output succeeds" (mockchainSucceeds $ failOnError (pingPongScriptTest Scripts.Pong))
+        , testGroup
+            "ping-pong"
+            [ testCase
+                "Ping and Pong should succeed"
+                ( mockchainSucceeds $
+                    failOnError
+                      (pingPongMultipleRounds Scripts.Pinged [Scripts.Pong])
+                )
+            , testCase
+                "Pong and Ping should succeed"
+                ( mockchainSucceeds $
+                    failOnError (pingPongMultipleRounds Scripts.Ponged [Scripts.Ping])
+                )
+            , testCase
+                "Ping and Ping should fail"
+                ( mockchainFails
+                    (failOnError (pingPongMultipleRounds Scripts.Pinged [Scripts.Ping]))
+                    -- Test tree fails
+                    (\_ -> pure ())
+                )
+            , testCase
+                "Pong and Pong should fail"
+                ( mockchainFails
+                    (failOnError (pingPongMultipleRounds Scripts.Ponged [Scripts.Pong]))
+                    -- Test tree fails
+                    (\_ -> pure ())
+                )
+            , testCase
+                "Stop after Ping should succeed"
+                ( mockchainSucceeds $
+                    failOnError (pingPongMultipleRounds Scripts.Ponged [Scripts.Ping, Scripts.Stop])
+                )
+            , testCase
+                "Stop after Pong should succeed"
+                ( mockchainSucceeds $
+                    failOnError (pingPongMultipleRounds Scripts.Pinged [Scripts.Pong, Scripts.Stop])
+                )
+            , testCase
+                "Stop after Stop should fail"
+                ( mockchainFails
+                    (failOnError (pingPongMultipleRounds Scripts.Stopped [Scripts.Stop]))
+                    -- Test tree fails
+                    (\_ -> pure ())
+                )
+            , testCase
+                "Ping after Stop should fail"
+                ( mockchainFails
+                    (failOnError (pingPongMultipleRounds Scripts.Stopped [Scripts.Ping]))
+                    -- Test tree fails
+                    (\_ -> pure ())
+                )
+            , testCase
+                "Pong after Stop should fail"
+                ( mockchainFails
+                    (failOnError (pingPongMultipleRounds Scripts.Stopped [Scripts.Pong]))
+                    -- Test tree fails
+                    (\_ -> pure ())
+                )
+            ]
         ]
     , testGroup
         "mockchain"
@@ -451,7 +509,7 @@ sampleScriptTest
      )
   => Scripts.SampleRedeemer
   -> m ()
-sampleScriptTest redemer = inBabbage @era $ do
+sampleScriptTest redeemer = inBabbage @era $ do
   let txBody =
         execBuildTx
           ( BuildTx.payToScriptDatumHash
@@ -465,55 +523,51 @@ sampleScriptTest redemer = inBabbage @era $ do
   input <- C.TxIn . C.getTxId . C.getTxBody <$> tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange [] <*> pure (C.TxIx 0)
 
   -- Spend!! the outputs in a single transaction
-  _tx <- tryBalanceAndSubmit mempty Wallet.w1 (execBuildTx $ Scripts.spendSample redemer input) TrailingChange []
+  _tx <- tryBalanceAndSubmit mempty Wallet.w1 (execBuildTx $ Scripts.spendSample redeemer input) TrailingChange []
   pure ()
 
-pingPongScriptTest
+pingPongMultipleRounds
   :: forall era m
    . ( MonadMockchain era m
      , MonadError (BalanceTxError era) m
      , MonadFail m
      , C.IsBabbageBasedEra era
      , C.HasScriptLanguageInEra C.PlutusScriptV3 era
      )
-  => Scripts.PingPongRedeemer
+  => Scripts.PingPongState
+  -> [Scripts.PingPongRedeemer]
   -> m ()
-pingPongScriptTest redemer = inBabbage @era $ do
+pingPongMultipleRounds fstState redeemers = inBabbage @era $ do
+  let value = 10_000_000
+  -- this is the inital state and will not be validated
+  -- we should prepare the state based on what we are about to play
   let txBody =
         execBuildTx
           ( BuildTx.payToScriptInlineDatum
               Defaults.networkId
               (C.hashScript (plutusScript Scripts.pingPongValidatorScript))
-              Scripts.Pinged
+              -- we should start with Pinged if redeemer is Pong
+              -- and Ponged if redeemer is Ping
+              fstState
               C.NoStakeAddress
-              (C.lovelaceToValue 10_000_000)
+              (C.lovelaceToValue value)
           )
-  -- here is the locking !!!
   tx <- tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange []
-  -- error $ show tx
-
-  let input = C.TxIn (C.getTxId $ C.getTxBody tx) (C.TxIx 0)
-  -- input <- C.TxBody . C.getTxId . C.getTxBody <$> tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange [] <*> pure (C.TxIx 0)
-
-  -- Spend!! the outputs in a single transaction
-  _tx <-
-    tryBalanceAndSubmit
-      mempty
-      Wallet.w1
-      ( execBuildTx $ do
-          Scripts.spendPingPong redemer input
-          --
-          -- here we are going to payToScript
-          BuildTx.payToScriptInlineDatum
-            Defaults.networkId
-            (C.hashScript (plutusScript Scripts.pingPongValidatorScript))
-            Scripts.Ponged
-            C.NoStakeAddress
-            (C.lovelaceToValue 10_000_000) -- add to the witness the datum
-      )
-      TrailingChange
-      []
+  _ <- play value tx redeemers
   pure ()
+ where
+  play _ tx [] = pure tx
+  play value tx (redeemer : xs) = do
+    newTx <-
+      tryBalanceAndSubmit
+        mempty
+        Wallet.w1
+        (execBuildTx $ Scripts.playPingPongRound Defaults.networkId value redeemer (getTxIn tx))
+        TrailingChange
+        []
+    play value newTx xs
+
+  getTxIn tx = C.TxIn (C.getTxId $ C.getTxBody tx) (C.TxIx 0)
 
 scriptStakingCredential :: C.StakeCredential
 scriptStakingCredential = C.StakeCredentialByScript $ C.hashScript (C.PlutusScript C.PlutusScriptV2 Scripts.v2StakingScript)
