Audit changes

CHANGELOG.md

@@ -17,6 +17,9 @@
   present but somehow disapeared.
 - It is now possible to reference an output which has a hashed datum.
 - `txSkelHashedData` the gives all the datum hashes in inputs and reference inputs.
+- Partial support for withdrawals in txSkels. The rewarding scripts will be ran
+  and assets will be transferred. However, these withdrawals are not properly
+  constrainted yet.
 
 ### Removed
 

cooked-validators.cabal

@@ -42,6 +42,7 @@ library
       Cooked.MockChain.GenerateTx.Mint
       Cooked.MockChain.GenerateTx.Output
       Cooked.MockChain.GenerateTx.Proposal
+      Cooked.MockChain.GenerateTx.Withdrawals
       Cooked.MockChain.GenerateTx.Witness
       Cooked.MockChain.MinAda
       Cooked.MockChain.MockChainSt
@@ -172,6 +173,7 @@ test-suite spec
       Cooked.Tweak.TamperDatumSpec
       Cooked.Tweak.ValidityRangeSpec
       Cooked.TweakSpec
+      Cooked.WithdrawalsSpec
       Paths_cooked_validators
   autogen-modules:
       Paths_cooked_validators

src/Cooked/MockChain/Balancing.hs

@@ -278,17 +278,18 @@ estimateTxSkelFee skel fee collateralIns returnCollateralWallet = do
 
 -- | This creates a balanced skeleton from a given skeleton and fee. In other
 -- words, this ensures that the following equation holds: input value + minted
--- value = output value + burned value + fee + deposits
+-- value + withdrawn value = output value + burned value + fee + deposits
 computeBalancedTxSkel :: (MonadBlockChainBalancing m) => Wallet -> BalancingOutputs -> TxSkel -> Fee -> m TxSkel
 computeBalancedTxSkel balancingWallet balancingUtxos txSkel@TxSkel {..} (Script.lovelace -> feeValue) = do
   -- We compute the necessary values from the skeleton that are part of the
   -- equation, except for the `feeValue` which we already have.
   let (burnedValue, mintedValue) = Api.split $ txSkelMintsValue txSkelMints
       outValue = txSkelValueInOutputs txSkel
+      withdrawnValue = txSkelWithdrawnValue txSkel
   inValue <- txSkelInputValue txSkel
   depositedValue <- toValue <$> txSkelProposalsDeposit txSkel
   -- We compute the values missing in the left and right side of the equation
-  let (missingRight, missingLeft) = Api.split $ outValue <> burnedValue <> feeValue <> depositedValue <> PlutusTx.negate (inValue <> mintedValue)
+  let (missingRight, missingLeft) = Api.split $ outValue <> burnedValue <> feeValue <> depositedValue <> PlutusTx.negate (inValue <> mintedValue <> withdrawnValue)
   -- This gives us what we need to run our `reachValue` algorithm and append to
   -- the resulting values whatever payment was missing in the initial skeleton
   let candidatesRaw = second (<> missingRight) <$> reachValue balancingUtxos missingLeft (toInteger $ length balancingUtxos)

src/Cooked/MockChain/GenerateTx/Body.hs

@@ -17,6 +17,7 @@ import Cooked.MockChain.GenerateTx.Input qualified as Input
 import Cooked.MockChain.GenerateTx.Mint qualified as Mint
 import Cooked.MockChain.GenerateTx.Output qualified as Output
 import Cooked.MockChain.GenerateTx.Proposal qualified as Proposal
+import Cooked.MockChain.GenerateTx.Withdrawals qualified as Withdrawals
 import Cooked.Skeleton
 import Cooked.Wallet
 import Data.Either.Combinators
@@ -59,6 +60,11 @@ instance Transform TxContext Input.InputContext where
 instance Transform TxContext Collateral.CollateralContext where
   transform TxContext {..} = Collateral.CollateralContext {..}
 
+instance Transform TxContext Withdrawals.WithdrawalsContext where
+  transform TxContext {..} =
+    let networkId = Emulator.pNetworkId params
+     in Withdrawals.WithdrawalsContext {..}
+
 -- | Generates a body content from a skeleton
 txSkelToBodyContent :: TxSkel -> BodyGen (Cardano.TxBodyContent Cardano.BuildTx Cardano.ConwayEra)
 txSkelToBodyContent skel@TxSkel {..} | txSkelReferenceInputs <- txSkelReferenceTxOutRefs skel = do
@@ -91,9 +97,9 @@ txSkelToBodyContent skel@TxSkel {..} | txSkelReferenceInputs <- txSkelReferenceT
   txProposalProcedures <-
     Just . Cardano.Featured Cardano.ConwayEraOnwardsConway
       <$> liftTxGen (Proposal.toProposalProcedures txSkelProposals (txOptAnchorResolution txSkelOpts))
+  txWithdrawals <- liftTxGen (Withdrawals.toWithdrawals txSkelWithdrawals)
   let txMetadata = Cardano.TxMetadataNone -- That's what plutus-apps does as well
       txAuxScripts = Cardano.TxAuxScriptsNone -- That's what plutus-apps does as well
-      txWithdrawals = Cardano.TxWithdrawalsNone -- That's what plutus-apps does as well
       txUpdateProposal = Cardano.TxUpdateProposalNone -- That's what plutus-apps does as well
       txCertificates = Cardano.TxCertificatesNone -- That's what plutus-apps does as well
       txScriptValidity = Cardano.TxScriptValidityNone -- That's what plutus-apps does as well
@@ -104,6 +110,7 @@ txSkelToBodyContent skel@TxSkel {..} | txSkelReferenceInputs <- txSkelReferenceT
 -- sign it with the required signers.
 txSkelToCardanoTx :: TxSkel -> BodyGen (Cardano.Tx Cardano.ConwayEra)
 txSkelToCardanoTx txSkel = do
+  -- We begin by creating the body content of the transaction
   txBodyContent <- txSkelToBodyContent txSkel
 
   -- We create the associated Shelley TxBody

src/Cooked/MockChain/GenerateTx/Withdrawals.hs

@@ -0,0 +1,58 @@
+module Cooked.MockChain.GenerateTx.Withdrawals
+  ( WithdrawalsContext (..),
+    toWithdrawals,
+  )
+where
+
+import Cardano.Api qualified as Cardano
+import Cardano.Api.Ledger qualified as Cardano
+import Cardano.Api.Shelley qualified as Cardano
+import Control.Monad
+import Control.Monad.Reader
+import Cooked.Conversion
+import Cooked.MockChain.GenerateTx.Common
+import Cooked.MockChain.GenerateTx.Witness
+import Cooked.Skeleton
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Ledger.Tx.CardanoAPI qualified as Ledger
+import Plutus.Script.Utils.Ada qualified as Script
+import PlutusLedgerApi.V3 qualified as Api
+
+data WithdrawalsContext where
+  WithdrawalsContext ::
+    { managedTxOuts :: Map Api.TxOutRef Api.TxOut,
+      networkId :: Cardano.NetworkId
+    } ->
+    WithdrawalsContext
+
+instance Transform WithdrawalsContext (Map Api.TxOutRef Api.TxOut) where
+  transform = managedTxOuts
+
+type WithdrawalsGen a = TxGen WithdrawalsContext a
+
+toWithdrawals :: TxSkelWithdrawals -> WithdrawalsGen (Cardano.TxWithdrawals Cardano.BuildTx Cardano.ConwayEra)
+toWithdrawals (Map.toList -> []) = return Cardano.TxWithdrawalsNone
+toWithdrawals (Map.toList -> withdrawals) =
+  fmap
+    (Cardano.TxWithdrawals Cardano.ShelleyBasedEraConway)
+    $ forM withdrawals
+    $ \(staker, Script.Lovelace n) ->
+      do
+        (witness, sCred) <-
+          case staker of
+            Right pkh -> do
+              sCred <-
+                throwOnToCardanoError "toWithdrawals: unable to translate pkh stake credential" $
+                  Cardano.StakeCredentialByKey <$> Ledger.toCardanoStakeKeyHash pkh
+              return (Cardano.KeyWitness Cardano.KeyWitnessForStakeAddr, sCred)
+            Left (script, red) -> do
+              witness <-
+                Cardano.ScriptWitness Cardano.ScriptWitnessForStakeAddr
+                  <$> liftTxGen (toScriptWitness script red Cardano.NoScriptDatumForStake)
+              sCred <-
+                throwOnToCardanoError "toWithdrawals: unable to translate script stake credential" $
+                  Cardano.StakeCredentialByScript <$> Ledger.toCardanoScriptHash (toScriptHash script)
+              return (witness, sCred)
+        networkId <- asks networkId
+        return (Cardano.makeStakeAddress networkId sCred, Cardano.Coin n, Cardano.BuildTxWith witness)

src/Cooked/Pretty/Cooked.hs

@@ -170,7 +170,7 @@ instance PrettyCooked MockChainLog where
       go acc [] = reverse acc
 
 prettyTxSkel :: PrettyCookedOpts -> SkelContext -> TxSkel -> DocCooked
-prettyTxSkel opts skelContext (TxSkel lbl txopts mints signers validityRange ins insReference outs proposals) =
+prettyTxSkel opts skelContext (TxSkel lbl txopts mints signers validityRange ins insReference outs proposals withdrawals) =
   prettyItemize
     "transaction skeleton:"
     "-"
@@ -183,10 +183,24 @@ prettyTxSkel opts skelContext (TxSkel lbl txopts mints signers validityRange ins
           prettyItemizeNonEmpty "Inputs:" "-" (prettyTxSkelIn opts skelContext <$> Map.toList ins),
           prettyItemizeNonEmpty "Reference inputs:" "-" (mapMaybe (prettyTxSkelInReference opts skelContext) $ Set.toList insReference),
           prettyItemizeNonEmpty "Outputs:" "-" (prettyTxSkelOut opts <$> outs),
-          prettyItemizeNonEmpty "Proposals:" "-" (prettyTxSkelProposal opts <$> proposals)
+          prettyItemizeNonEmpty "Proposals:" "-" (prettyTxSkelProposal opts <$> proposals),
+          prettyWithdrawals opts withdrawals
         ]
     )
 
+prettyWithdrawals :: PrettyCookedOpts -> TxSkelWithdrawals -> Maybe DocCooked
+prettyWithdrawals pcOpts withdrawals =
+  prettyItemizeNonEmpty "Withdrawals:" "-" $ prettyWithdrawal <$> Map.toList withdrawals
+  where
+    prettyWithdrawal :: (Either (Script.Versioned Script.Script, TxSkelRedeemer) Api.PubKeyHash, Script.Ada) -> DocCooked
+    prettyWithdrawal (cred, ada) =
+      prettyItemizeNoTitle "-" $
+        ( case cred of
+            Left (script, red) -> prettyCookedOpt pcOpts script : prettyTxSkelRedeemer pcOpts red
+            Right pkh -> [prettyCookedOpt pcOpts pkh]
+        )
+          ++ [prettyCookedOpt pcOpts (toValue ada)]
+
 prettyTxParameterChange :: PrettyCookedOpts -> TxParameterChange -> DocCooked
 prettyTxParameterChange opts (FeePerByte n) = "Fee per byte:" <+> prettyCookedOpt opts n
 prettyTxParameterChange opts (FeeFixed n) = "Fee fixed:" <+> prettyCookedOpt opts n

src/Cooked/ShowBS.hs

@@ -370,7 +370,7 @@ instance ShowBS Api.TxInfo where
       <> showBS txInfoMint
       <> "certificates:"
       <> showBS txInfoTxCerts
-      <> "wdrl:" -- TODO: what is wdrl? Explain better here
+      <> "wdrl:"
       <> showBS txInfoWdrl
       <> "valid range:"
       <> showBS txInfoValidRange

src/Cooked/Skeleton.hs

@@ -67,6 +67,8 @@ module Cooked.Skeleton
     txSkelProposalActionL,
     txSkelProposalWitnessL,
     txSkelProposalAnchorL,
+    TxSkelWithdrawals,
+    txSkelWithdrawnValue,
     TxSkel (..),
     txSkelLabelL,
     txSkelOptsL,
@@ -76,6 +78,7 @@ module Cooked.Skeleton
     txSkelInsL,
     txSkelInsReferenceL,
     txSkelOutsL,
+    txSkelWithdrawalsL,
     txSkelTemplate,
     txSkelDataInOutputs,
     txSkelValidatorsInOutputs,
@@ -119,6 +122,7 @@ import Data.Set qualified as Set
 import Ledger.Slot qualified as Ledger
 import Optics.Core
 import Optics.TH
+import Plutus.Script.Utils.Ada qualified as Script
 import Plutus.Script.Utils.Scripts qualified as Script
 import Plutus.Script.Utils.Typed qualified as Script hiding (validatorHash)
 import Plutus.Script.Utils.Value qualified as Script hiding (adaSymbol, adaToken)
@@ -582,6 +586,16 @@ withWitness prop (s, red) = prop {txSkelProposalWitness = Just (toScript s, red)
 withAnchor :: TxSkelProposal -> String -> TxSkelProposal
 withAnchor prop url = prop {txSkelProposalAnchor = Just url}
 
+-- * Description of the Withdrawals
+
+type TxSkelWithdrawals =
+  Map
+    (Either (Script.Versioned Script.Script, TxSkelRedeemer) Api.PubKeyHash)
+    Script.Ada
+
+txSkelWithdrawnValue :: TxSkel -> Api.Value
+txSkelWithdrawnValue = mconcat . (toValue . snd <$>) . Map.toList . txSkelWithdrawals
+
 -- * Description of the Minting
 
 -- | A description of what a transaction mints. For every policy, there can only
@@ -1014,8 +1028,11 @@ data TxSkel where
       -- | The outputs of the transaction. These will occur in exactly this
       -- order on the transaction.
       txSkelOuts :: [TxSkelOut],
-      -- | Possible proposals issued in this transaction to be voted on and possible enacted later on.
-      txSkelProposals :: [TxSkelProposal]
+      -- | Possible proposals issued in this transaction to be voted on and
+      -- possible enacted later on.
+      txSkelProposals :: [TxSkelProposal],
+      -- | Withdrawals performed by the transaction
+      txSkelWithdrawals :: TxSkelWithdrawals
     } ->
     TxSkel
   deriving (Show, Eq)
@@ -1029,7 +1046,8 @@ makeLensesFor
     ("txSkelIns", "txSkelInsL"),
     ("txSkelInsReference", "txSkelInsReferenceL"),
     ("txSkelOuts", "txSkelOutsL"),
-    ("txSkelProposals", "txSkelProposalsL")
+    ("txSkelProposals", "txSkelProposalsL"),
+    ("txSkelWithdrawals", "txSkelWithdrawalsL")
   ]
   ''TxSkel
 
@@ -1045,7 +1063,8 @@ txSkelTemplate =
       txSkelIns = Map.empty,
       txSkelInsReference = Set.empty,
       txSkelOuts = [],
-      txSkelProposals = []
+      txSkelProposals = [],
+      txSkelWithdrawals = Map.empty
     }
 
 -- | The missing information on a 'TxSkel' that can only be resolved by querying

tests/Cooked/WithdrawalsSpec.hs

@@ -0,0 +1,59 @@
+module Cooked.WithdrawalsSpec where
+
+import Control.Monad
+import Cooked
+import Data.Default
+import Data.Map qualified as Map
+import Plutus.Script.Utils.Ada qualified as Script
+import Plutus.Script.Utils.Scripts qualified as Script
+import PlutusLedgerApi.V3 qualified as Api
+import PlutusTx qualified
+import PlutusTx.AssocMap qualified as PMap
+import PlutusTx.Prelude qualified as PlutusTx
+import Test.Tasty
+import Test.Tasty.HUnit
+
+checkWithdrawalScript :: PlutusTx.BuiltinData -> PlutusTx.BuiltinData -> ()
+checkWithdrawalScript red ctx =
+  let scriptContext = PlutusTx.unsafeFromBuiltinData @Api.ScriptContext ctx
+      withdrawals = Api.txInfoWdrl PlutusTx.$ Api.scriptContextTxInfo scriptContext
+      quantity = PlutusTx.unsafeFromBuiltinData @Integer red
+      purpose = Api.scriptContextPurpose scriptContext
+   in case purpose of
+        Api.Rewarding cred -> case PMap.toList withdrawals of
+          [(cred', Api.Lovelace n)] ->
+            if cred PlutusTx.== cred'
+              then
+                if n PlutusTx.== quantity
+                  then ()
+                  else PlutusTx.traceError "Wrong quantity."
+              else PlutusTx.traceError "Wrong credential."
+          _ -> PlutusTx.traceError "Wrong withdrawal."
+        _ -> PlutusTx.traceError "Wrong script purpose."
+
+checkWithdrawalVersionedScript :: Script.Versioned Script.Script
+checkWithdrawalVersionedScript = mkScript $$(PlutusTx.compile [||checkWithdrawalScript||])
+
+testWithdrawingScript :: (MonadBlockChain m) => Integer -> Integer -> m ()
+testWithdrawingScript n1 n2 =
+  void $
+    validateTxSkel $
+      txSkelTemplate
+        { txSkelSigners = [wallet 1],
+          txSkelWithdrawals =
+            Map.singleton
+              (Left (checkWithdrawalVersionedScript, txSkelSomeRedeemer (n1 * 1_000 :: Integer)))
+              (Script.Lovelace $ n2 * 1_000)
+        }
+
+tests :: TestTree
+tests =
+  testGroup
+    "Withdrawing scripts"
+    [ testCase "We can use a withdrawing script" $
+        testSucceeds def $
+          testWithdrawingScript 2 2,
+      testCase "But the script might fail" $
+        testFailsFrom def (isCekEvaluationFailure def) def $
+          testWithdrawingScript 2 1
+    ]

tests/Spec.hs

@@ -11,6 +11,7 @@ import Cooked.ReferenceInputsSpec qualified as ReferenceInputsSpec
 import Cooked.ReferenceScriptsSpec qualified as ReferenceScriptsSpec
 import Cooked.ShowBSSpec qualified as ShowBSSpec
 import Cooked.TweakSpec qualified as TweakSpec
+import Cooked.WithdrawalsSpec qualified as WithdrawalsSpec
 import Test.Tasty
 
 main :: IO ()
@@ -30,5 +31,6 @@ main =
         MockChainSpec.tests,
         ShowBSSpec.tests,
         InitDistribSpec.tests,
-        ProposingSpec.tests
+        ProposingSpec.tests,
+        WithdrawalsSpec.tests
       ]