SCP-2494: Remove thread token from previous value of a state machine …

…step (#3625)

* Add test that reproduces the ThreadToken bug

* Remove thread token from previous value of a state machine step

Fixes #3546

* Add some comments

* updateMaterialized

plutus-contract/plutus-contract.cabal

@@ -172,6 +172,7 @@ test-suite plutus-contract-test
         Spec.Emulator
         Spec.Rows
         Spec.State
+        Spec.ThreadToken
     build-depends:
         base >=4.9 && <5,
         bytestring -any,

plutus-contract/src/Plutus/Contract/StateMachine.hs

@@ -462,7 +462,11 @@ mkStep client@StateMachineClient{scInstance} input = do
         Nothing -> pure $ Left $ InvalidTransition Nothing input
         Just (onChainState, utxo) -> do
             let (TypedScriptTxOut{tyTxOutData=currentState, tyTxOutTxOut}, txOutRef) = onChainState
-                oldState = State{stateData = currentState, stateValue = Ledger.txOutValue tyTxOutTxOut}
+                oldState = State
+                    { stateData = currentState
+                      -- Hide the thread token value from the client code
+                    , stateValue = Ledger.txOutValue tyTxOutTxOut <> inv (SM.threadTokenValueOrZero scInstance)
+                    }
                 inputConstraints = [InputConstraint{icRedeemer=input, icTxOutRef = Typed.tyTxOutRefRef txOutRef }]
 
             case smTransition oldState input of
@@ -475,7 +479,11 @@ mkStep client@StateMachineClient{scInstance} input = do
                         red = Ledger.Redeemer (PlutusTx.toBuiltinData (Scripts.validatorHash typedValidator, Burn))
                         unmint = if isFinal then mustMintValueWithRedeemer red (inv $ SM.threadTokenValueOrZero scInstance) else mempty
                         outputConstraints =
-                            [ OutputConstraint{ocDatum = stateData newState, ocValue = stateValue newState <> SM.threadTokenValueOrZero scInstance }
+                            [ OutputConstraint
+                                { ocDatum = stateData newState
+                                  -- Add the thread token value back to the output
+                                , ocValue = stateValue newState <> SM.threadTokenValueOrZero scInstance
+                                }
                             | not isFinal ]
                     in pure
                         $ Right

plutus-contract/src/Plutus/Contract/StateMachine/OnChain.hs

@@ -115,7 +115,11 @@ mkValidator (StateMachine step isFinal check threadToken) currentState input ptx
         checkOk =
             traceIfFalse "State transition invalid - checks failed" (check currentState input ptx)
             && traceIfFalse "Thread token not found" (TT.checkThreadToken threadToken (ownHash ptx) vl 1)
-        oldState = State{stateData=currentState, stateValue=vl}
+        oldState = State
+            { stateData = currentState
+              -- The thread token value is hidden from the client code
+            , stateValue = vl <> inv (threadTokenValueInner threadToken (ownHash ptx))
+            }
         stateAndOutputsOk = case step oldState input of
             Just (newConstraints, State{stateData=newData, stateValue=newValue})
                 | isFinal newData ->
@@ -127,6 +131,7 @@ mkValidator (StateMachine step isFinal check threadToken) currentState input ptx
                                 { txOwnOutputs=
                                     [ OutputConstraint
                                         { ocDatum = newData
+                                          -- Check that the thread token value is still there
                                         , ocValue = newValue <> threadTokenValueInner threadToken (ownHash ptx)
                                         }
                                     ]

plutus-contract/test/Spec.hs

@@ -5,6 +5,7 @@ import qualified Spec.Contract
 import qualified Spec.Emulator
 import qualified Spec.Rows
 import qualified Spec.State
+import qualified Spec.ThreadToken
 import           Test.Tasty
 
 main :: IO ()
@@ -15,5 +16,6 @@ tests = testGroup "plutus-contract" [
     Spec.Contract.tests,
     Spec.Emulator.tests,
     Spec.State.tests,
-    Spec.Rows.tests
+    Spec.Rows.tests,
+    Spec.ThreadToken.tests
     ]

plutus-contract/test/Spec/ThreadToken.hs

@@ -0,0 +1,98 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
+
+-- | Reduced example of the SM contract to reproduce the token handling in and around 'runStep'.
+module Spec.ThreadToken where
+
+import           PlutusTx.Prelude             hiding (Eq)
+import           Prelude                      (Show, String, show)
+
+import           Control.Monad                (void)
+import           GHC.Generics                 (Generic)
+import           Ledger.Typed.Scripts         (TypedValidator, mkTypedValidator)
+import qualified Ledger.Typed.Scripts         as Scripts
+import           Plutus.Contract              (Contract, EmptySchema, logError, mapError)
+import           Plutus.Contract.StateMachine (StateMachine, StateMachineClient, ThreadToken, mkStateMachine, stateData)
+import qualified Plutus.Contract.StateMachine as SM
+import           Plutus.Contract.Test
+import           Plutus.Trace                 (EmulatorTrace, activateContractWallet)
+import qualified Plutus.Trace                 as Trace
+import qualified PlutusTx
+
+import           Test.Tasty
+
+-- * Very simple plutus state machine using a thread token
+
+data State
+  = First
+  | Second
+  deriving (Generic, Show)
+
+PlutusTx.makeLift ''State
+PlutusTx.unstableMakeIsData ''State
+
+data Input
+  = Step
+  deriving (Generic, Show)
+PlutusTx.makeLift ''Input
+PlutusTx.unstableMakeIsData ''Input
+
+{-# INLINEABLE transition #-}
+transition :: SM.State State -> Input -> Maybe (SM.TxConstraints SM.Void SM.Void, SM.State State)
+transition oldState _ = Just (mempty, oldState{stateData = Second})
+
+{-# INLINEABLE stateMachine #-}
+stateMachine :: ThreadToken -> StateMachine State Input
+stateMachine threadToken =
+  mkStateMachine (Just threadToken) transition isFinal
+ where
+  isFinal = const False
+
+typedValidator :: ThreadToken -> TypedValidator (StateMachine State Input)
+typedValidator threadToken =
+  mkTypedValidator @(StateMachine State Input)
+    ($$(PlutusTx.compile [||validator||]) `PlutusTx.applyCode` PlutusTx.liftCode threadToken)
+    $$(PlutusTx.compile [||wrap||])
+ where
+  validator c = SM.mkValidator (stateMachine c)
+  wrap = Scripts.wrapValidator @State @Input
+
+stateMachineClient :: ThreadToken -> StateMachineClient State Input
+stateMachineClient threadToken =
+  let machine = stateMachine threadToken
+      inst = typedValidator threadToken
+   in SM.mkStateMachineClient (SM.StateMachineInstance machine inst)
+-- * Minimal test runner for repro
+
+contract :: Contract () EmptySchema String ()
+contract = do
+  threadToken <- mapSMError SM.getThreadToken
+  logError @String $ "Forged thread token: " <> show threadToken
+
+  let client = stateMachineClient threadToken
+  void $ mapSMError $ SM.runInitialise client First mempty
+  logError @String $ "Initialized state machine"
+
+  res <- mapSMError $ SM.runStep client Step
+  case res of
+    SM.TransitionFailure (SM.InvalidTransition os i) -> logError @String $ "Invalid transition: " <> show (os, i)
+    SM.TransitionSuccess s                           -> logError @String $ "Transition success: " <> show s
+ where
+  mapSMError = mapError (show @SM.SMContractError)
+
+testTrace :: EmulatorTrace ()
+testTrace = do
+  void $ activateContractWallet (Wallet 1) contract
+  void $ Trace.waitNSlots 10
+
+tests :: TestTree
+tests = testGroup "Thread Token"
+    [ checkPredicate "Runs successfully"
+        (assertDone contract (Trace.walletInstanceTag (Wallet 1)) (const True) "No errors"
+         .&&. assertNoFailedTransactions)
+        testTrace
+    ]

plutus-use-cases/test/Spec/gameStateMachine.pir

@@ -10290,7 +10290,31 @@
                                                         [
                                                           ww
                                                           [
-                                                            [ { State s } w ] vl
+                                                            [ { State s } w ]
+                                                            [
+                                                              [
+                                                                [
+                                                                  unionWith
+                                                                  addInteger
+                                                                ]
+                                                                vl
+                                                              ]
+                                                              [
+                                                                [
+                                                                  fAdditiveGroupValue_cscale
+                                                                  (con
+                                                                    integer -1
+                                                                  )
+                                                                ]
+                                                                [
+                                                                  [
+                                                                    threadTokenValueInner
+                                                                    ww
+                                                                  ]
+                                                                  [ ownHash w ]
+                                                                ]
+                                                              ]
+                                                            ]
                                                           ]
                                                         ]
                                                         w