Merge branch 'develop' of github.com:Plutonomicon/cardano-transaction…

…-lib into Luis-omega/QuickCheck
MitchyCola · Jun 16, 2022 · 9fb8f36 · 9fb8f36
2 parents 75d247b + 19be54b
commit 9fb8f36
Show file tree

Hide file tree

Showing 12 changed files with 559 additions and 193 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -16,6 +16,10 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/)
 
 - `FromPlutusType` / `ToPlutusType` type classes.
 
+### Fixed
+
+- Aeson instance for `TokenName` doesn't handle invalid UTF8 byte sequences.
+
 ## [1.0.0] - 2022-06-10
 
 CTL's initial release!
diff --git a/Makefile b/Makefile
@@ -1,6 +1,6 @@
 SHELL := bash
 .ONESHELL:
-.PHONY: autogen-deps run-testnet-node run-testnet-ogmios
+.PHONY: run-dev run-build check-format format run-datum-cache-postgres-console query-testnet-tip clean
 .SHELLFLAGS := -eu -o pipefail -c
 
 ps-sources := $(shell fd -epurs)
@@ -28,3 +28,12 @@ run-datum-cache-postgres-console:
 query-testnet-tip:
 	CARDANO_NODE_SOCKET_PATH=${node-ipc}/node.socket cardano-cli query tip \
 	  --testnet-magic 1097911063
+
+clean:
+	@ rm -rf dist-newstyle || true
+	@ rm -r .psc-ide-port || true
+	@ rm -rf .psci_modules || true
+	@ rm -rf .spago || true
+	@ rm -rf .spago2nix || true
+	@ rm -rf node_modules || true
+	@ rm -rf output || true
diff --git a/examples/MintsMultipleTokens.purs b/examples/MintsMultipleTokens.purs
diff --git a/src/BalanceTx.purs b/src/BalanceTx.purs
@@ -27,8 +27,10 @@ import Cardano.Types.Transaction
   , Utxo
   , _body
   , _collateral
+  , _fee
   , _inputs
   , _networkId
+  , _outputs
   , _plutusData
   , _redeemers
   , _witnessSet
@@ -47,10 +49,11 @@ import Cardano.Types.Value
   , minus
   , mkCoin
   , mkValue
-  , numCurrencySymbols
-  , numTokenNames
+  , numNonAdaAssets
+  , numNonAdaCurrencySymbols
   , sumTokenNameLengths
   , valueToCoin
+  , valueToCoin'
   , Value
   )
 import Control.Monad.Except.Trans
@@ -61,7 +64,7 @@ import Control.Monad.Except.Trans
 import Control.Monad.Logger.Class (class MonadLogger)
 import Control.Monad.Logger.Class as Logger
 import Control.Monad.Reader.Class (asks)
-import Data.Array ((\\), findIndex, modifyAt)
+import Data.Array ((\\), modifyAt)
 import Data.Array as Array
 import Data.Bifunctor (bimap, lmap)
 import Data.BigInt (BigInt, fromInt, quot)
@@ -266,10 +269,10 @@ type UnattachedTransaction = Transaction /\ Array
 -- Evaluation of fees and execution units, Updating redeemers
 --------------------------------------------------------------------------------
 
--- | Calculates the execution units needed for each script in the transaction
--- | and the minimum fee, including the script fees.
--- | Returns a tuple consisting of updated `UnattachedUnbalancedTx` and
--- | the minimum fee.
+-- Calculates the execution units needed for each script in the transaction
+-- and the minimum fee, including the script fees.
+-- Returns a tuple consisting of updated `UnattachedUnbalancedTx` and
+-- the minimum fee.
 evalExUnitsAndMinFee'
   :: UnattachedUnbalancedTx
   -> QueryM
@@ -426,7 +429,6 @@ balanceTx unattachedTx@(UnattachedUnbalancedTx { unbalancedTx: t }) = do
 
     -- Logging Unbalanced Tx with collateral added:
     logTx "Unbalanced Collaterised Tx " allUtxos unbalancedCollTx
-
     -- Prebalance collaterised tx without fees:
     ubcTx <- except $
       prebalanceCollateral zero allUtxos ownAddr unbalancedCollTx
@@ -440,7 +442,7 @@ balanceTx unattachedTx@(UnattachedUnbalancedTx { unbalancedTx: t }) = do
       _transaction' .~ ubcTx'
     -- Return excess Ada change to wallet:
     unsignedTx <- ExceptT $
-      returnAdaChange ownAddr allUtxos nonAdaBalancedCollTx <#>
+      returnAdaChangeAndFinalizeFees ownAddr allUtxos nonAdaBalancedCollTx <#>
         lmap ReturnAdaChangeError'
     let
       unattachedTx'' = unsignedTx ^. _transaction'
@@ -555,137 +557,141 @@ logTx msg utxos (Transaction { body: body'@(TxBody body) }) =
     , "Fees: " <> show body.fee
     ]
 
--- Transaction should be prebalanced at this point with all excess with Ada
--- where the Ada value of inputs is greater or equal to value of outputs.
--- Also add fees to txBody. This should be called with a Tx with min
--- Ada in each output utxo, namely, after "loop".
-returnAdaChange
+-- Transaction should be pre-balanced at this point, and the Ada value of the
+-- inputs should be greater than or equal to the value of the outputs.
+-- This should be called with a Tx with min Ada in each output utxo,
+-- namely, after "loop".
+returnAdaChangeAndFinalizeFees
   :: Address
   -> Utxo
   -> UnattachedUnbalancedTx
   -> QueryM (Either ReturnAdaChangeError UnattachedUnbalancedTx)
-returnAdaChange changeAddr utxos unattachedTx =
+returnAdaChangeAndFinalizeFees changeAddr utxos unattachedTx =
   runExceptT do
-    unattachedTx' /\ fees <- ExceptT $ evalExUnitsAndMinFee' unattachedTx
-      <#> lmap ReturnAdaChangeCalculateMinFee
-    let
-      TxBody txBody = unattachedTx' ^. _body'
+    -- Calculate min fee before returning ada change to the owner's address:
+    unattachedTxAndFees@(_ /\ fees) <-
+      ExceptT $ evalExUnitsAndMinFee' unattachedTx
+        <#> lmap ReturnAdaChangeCalculateMinFee
+    -- If required, create an extra output to return the change:
+    unattachedTxWithChangeTxOut /\ { recalculateFees } <-
+      except $ returnAdaChange changeAddr utxos unattachedTxAndFees
+    case recalculateFees of
+      false -> except <<< Right $
+        -- Set min fee and return tx without recalculating fees:
+        unattachedTxSetFees unattachedTxWithChangeTxOut fees
+      true -> do
+        -- Recalculate min fee, then adjust the change output:
+        unattachedTx' /\ fees' <-
+          ExceptT $ evalExUnitsAndMinFee' unattachedTxWithChangeTxOut
+            <#> lmap ReturnAdaChangeCalculateMinFee
+        except $
+          adjustAdaChangeAndSetFees unattachedTx' fees' (fees' - fees)
+  where
+  adjustAdaChangeAndSetFees
+    :: UnattachedUnbalancedTx
+    -> BigInt
+    -> BigInt
+    -> Either ReturnAdaChangeError UnattachedUnbalancedTx
+  adjustAdaChangeAndSetFees unattachedTx' fees feesDelta
+    | feesDelta <= zero = Right $
+        unattachedTxSetFees unattachedTx' fees
+    | otherwise =
+        let
+          txOutputs :: Array TransactionOutput
+          txOutputs = unattachedTx' ^. _body' <<< _outputs
 
-      txOutputs :: Array TransactionOutput
-      txOutputs = txBody.outputs
+          returnAda :: BigInt
+          returnAda = fromMaybe zero $
+            Array.head txOutputs <#> \(TransactionOutput rec) ->
+              (valueToCoin' rec.amount) - feesDelta
 
-      inputValue :: Value
-      inputValue = getInputValue utxos (wrap txBody)
+          utxoCost :: BigInt
+          utxoCost = getLovelace protocolParamUTxOCostPerWord
 
-      inputAda :: BigInt
-      inputAda = getLovelace $ valueToCoin inputValue
+          changeMinUtxo :: BigInt
+          changeMinUtxo = adaOnlyWords * utxoCost
+        in
+          case returnAda >= changeMinUtxo of
+            true -> do
+              newOutputs <- updateChangeTxOutputValue returnAda txOutputs
+              pure $
+                unattachedTx' # _body' %~ \(TxBody txBody) ->
+                  wrap txBody { outputs = newOutputs, fee = wrap fees }
+            false ->
+              Left $
+                ReturnAdaChangeError
+                  "returnAda does not cover min utxo requirement for \
+                  \single Ada-only output."
+
+  unattachedTxSetFees
+    :: UnattachedUnbalancedTx -> BigInt -> UnattachedUnbalancedTx
+  unattachedTxSetFees unattachedTx' fees =
+    unattachedTx' #
+      _body' <<< _fee .~ wrap fees
+
+  updateChangeTxOutputValue
+    :: BigInt
+    -> Array TransactionOutput
+    -> Either ReturnAdaChangeError (Array TransactionOutput)
+  updateChangeTxOutputValue returnAda =
+    note (ReturnAdaChangeError "Couldn't modify utxo to return change.")
+      <<< modifyAt zero
+        \(TransactionOutput rec) -> TransactionOutput
+          rec { amount = lovelaceValueOf returnAda }
 
-      -- FIX ME, ignore mint value?
-      outputValue :: Value
-      outputValue = Array.foldMap getAmount txOutputs
+returnAdaChange
+  :: Address
+  -> Utxo
+  -> UnattachedUnbalancedTx /\ BigInt
+  -> Either ReturnAdaChangeError
+       (UnattachedUnbalancedTx /\ { recalculateFees :: Boolean })
+returnAdaChange changeAddr utxos (unattachedTx /\ fees) =
+  let
+    TxBody txBody = unattachedTx ^. _body'
 
-      outputAda :: BigInt
-      outputAda = getLovelace $ valueToCoin outputValue
+    txOutputs :: Array TransactionOutput
+    txOutputs = txBody.outputs
+
+    inputValue :: Value
+    inputValue = getInputValue utxos (wrap txBody)
+
+    inputAda :: BigInt
+    inputAda = getLovelace $ valueToCoin inputValue
+
+    outputValue :: Value
+    outputValue = Array.foldMap getAmount txOutputs
+
+    outputAda :: BigInt
+    outputAda = getLovelace $ valueToCoin outputValue
 
-      returnAda :: BigInt
-      returnAda = inputAda - outputAda - fees
+    returnAda :: BigInt
+    returnAda = inputAda - outputAda - fees
+  in
     case compare returnAda zero of
+      EQ ->
+        Right $
+          unattachedTx /\ { recalculateFees: false }
       LT ->
-        except $ Left $
+        Left $
           ReturnAdaChangeImpossibleError
             "Not enough Input Ada to cover output and fees after prebalance."
             Impossible
-      EQ -> do
-        except $ Right $ unattachedTx' # _body' .~
-          wrap txBody { fee = wrap fees }
-      GT -> ExceptT do
-        -- Short circuits and adds Ada to any output utxo of the owner. This saves
-        -- on fees but does not create a separate utxo. Do we want this behaviour?
-        -- I expect if there are any output utxos to the user, they are either Ada
-        -- only or non-Ada with minimum Ada value. Either way, we can just add the
-        -- the value and it shouldn't incur extra fees.
-        -- If we do require a new utxo, then we must add fees, under the assumption
-        -- we have enough Ada in the input at this stage, otherwise we fail because
-        -- we don't want to loop again over the addition of one output utxo.
+      GT ->
         let
-          changeIndex :: Maybe Int
-          changeIndex =
-            findIndex ((==) changeAddr <<< _.address <<< unwrap)
-              txOutputs
-
-        case changeIndex of
-          Just idx -> pure do
-            -- Add the Ada value to the first output utxo of the owner to not
-            -- concur fees. This should be Ada only or non-Ada which has min Ada.
-            newOutputs <-
-              note
-                ( ReturnAdaChangeError
-                    "Couldn't modify utxo to return change."
-                ) $
-                modifyAt
-                  idx
-                  ( \(TransactionOutput o@{ amount }) -> TransactionOutput
-                      o { amount = amount <> lovelaceValueOf returnAda }
-                  )
-                  txOutputs
-            -- Fees unchanged because we aren't adding a new utxo.
-            pure $ unattachedTx' # _body' .~
-              wrap txBody { outputs = newOutputs, fee = wrap fees }
-          Nothing -> do
-            -- Create a txBody with the extra output utxo then recalculate fees,
-            -- then adjust as necessary if we have sufficient Ada in the input.
-            let
-              utxoCost :: BigInt
-              utxoCost = getLovelace protocolParamUTxOCostPerWord
-
-              changeMinUtxo :: BigInt
-              changeMinUtxo = adaOnlyWords * utxoCost
-
-              txBody' :: TxBody
-              txBody' =
-                wrap
-                  txBody
-                    { outputs =
-                        wrap
-                          { address: changeAddr
-                          , amount: lovelaceValueOf returnAda
-                          , dataHash: Nothing
-                          }
-                          `Array.cons` txBody.outputs
-                    }
-
-              unattachedTx'' :: UnattachedUnbalancedTx
-              unattachedTx'' =
-                unattachedTx' # _body' .~ txBody'
-
-            unattachedTxWithFees <- evalExUnitsAndMinFee' unattachedTx''
-              <#> lmap ReturnAdaChangeCalculateMinFee
-            -- fees should increase.
-            pure $ unattachedTxWithFees >>= \(unattachedTx''' /\ fees') -> do
-              -- New return Ada amount should decrease:
-              let returnAda' = returnAda + fees - fees'
-
-              if returnAda' >= changeMinUtxo then do
-                newOutputs <-
-                  note
-                    ( ReturnAdaChangeImpossibleError
-                        "Couldn't modify head utxo to add Ada"
-                        Impossible
-                    )
-                    $ modifyAt
-                        0
-                        ( \(TransactionOutput o) -> TransactionOutput
-                            o { amount = lovelaceValueOf returnAda' }
-                        )
-                    $ _.outputs <<< unwrap
-                    $ txBody'
-                pure $ unattachedTx''' # _body' .~
-                  wrap txBody { outputs = newOutputs, fee = wrap fees' }
-              else
-                Left $
-                  ReturnAdaChangeError
-                    "ReturnAda' does not cover min. utxo requirement for \
-                    \single Ada-only output."
+          changeTxOutput :: TransactionOutput
+          changeTxOutput = wrap
+            { address: changeAddr
+            , amount: lovelaceValueOf returnAda
+            , dataHash: Nothing
+            }
+
+          unattachedTxWithChangeTxOut :: UnattachedUnbalancedTx
+          unattachedTxWithChangeTxOut =
+            unattachedTx # _body' <<< _outputs %~
+              Array.cons changeTxOutput
+        in
+          Right $
+            unattachedTxWithChangeTxOut /\ { recalculateFees: true }
 
 calculateMinUtxos :: Array TransactionOutput -> MinUtxos
 calculateMinUtxos = map (\a -> a /\ calculateMinUtxo a)
@@ -725,9 +731,9 @@ size :: Value -> BigInt
 size v = fromInt 6 + roundupBytesToWords b
   where
   b :: BigInt
-  b = numTokenNames v * fromInt 12
+  b = numNonAdaAssets v * fromInt 12
     + sumTokenNameLengths v
-    + numCurrencySymbols v * pidSize
+    + numNonAdaCurrencySymbols v * pidSize
 
   -- https://cardano-ledger.readthedocs.io/en/latest/explanations/min-utxo-mary.html
   -- Converts bytes to 8-byte long words, rounding up