Merge pull request #1640 from input-output-hk/uroboros/fix_unexpected…

…_deposit_pot

Fix totalDeposits and re-enable generation of Updates in Txs

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/UTxO.hs

@@ -42,7 +42,6 @@ import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Crypto.Hash (hashWithSerialiser)
 import Cardano.Prelude (Generic, NFData, NoUnexpectedThunks (..))
 import Data.Foldable (toList)
-import Data.List (foldl')
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import qualified Data.Maybe as Maybe
@@ -58,20 +57,20 @@ import Shelley.Spec.Ledger.Crypto
 import Shelley.Spec.Ledger.Delegation.Certificates
   ( DCert (..),
     StakePools (..),
-    dvalue,
+    isRegKey,
     requiresVKeyWitness,
   )
 import Shelley.Spec.Ledger.Keys
   ( DSignable,
     Hash,
     KeyHash (..),
     KeyPair (..),
-    KeyRole (Witness),
+    KeyRole (StakePool, Witness),
     asWitness,
     signedDSIGN,
     verifySignedDSIGN,
   )
-import Shelley.Spec.Ledger.PParams (PParams, Update)
+import Shelley.Spec.Ledger.PParams (PParams, Update, _keyDeposit, _poolDeposit)
 import Shelley.Spec.Ledger.Scripts
 import Shelley.Spec.Ledger.Tx (Tx (..))
 import Shelley.Spec.Ledger.TxData
@@ -220,19 +219,30 @@ balance (UTxO utxo) = foldr addCoins 0 utxo
   where
     addCoins (TxOut _ a) b = a + b
 
--- | Determine the total deposit amount needed
+-- | Determine the total deposit amount needed.
+-- The block may (legitimately) contain multiple registration certificates
+-- for the same pool, where the first will be treated as a registration and
+-- any subsequent ones as re-registration. As such, we must only take a
+-- deposit for the first such registration.
+--
+-- Note that this is not an issue for key registrations since subsequent
+-- registration certificates would be invalid.
 totalDeposits ::
   PParams ->
   StakePools crypto ->
   [DCert crypto] ->
   Coin
-totalDeposits pc (StakePools stpools) cs = foldl' f (Coin 0) cs'
+totalDeposits pp (StakePools stpools) cs =
+  (_keyDeposit pp) * numKeys + (_poolDeposit pp) * numNewPools
   where
-    f coin cert = coin + dvalue cert pc
-    notRegisteredPool (DCertPool (RegPool pool)) =
-      Map.notMember (_poolPubKey pool) stpools
-    notRegisteredPool _ = True
-    cs' = filter notRegisteredPool cs
+    numKeys = intToCoin . length $ filter isRegKey cs
+    pools = Set.fromList . Maybe.catMaybes $ fmap getKeyHashFromRegPool cs
+    numNewPools = intToCoin . length $ pools `Set.difference` (Map.keysSet stpools)
+    intToCoin = Coin . toInteger
+
+getKeyHashFromRegPool :: DCert crypto -> Maybe (KeyHash 'StakePool crypto)
+getKeyHashFromRegPool (DCertPool (RegPool p)) = Just . _poolPubKey $ p
+getKeyHashFromRegPool _ = Nothing
 
 txup :: Crypto crypto => Tx crypto -> Maybe (Update crypto)
 txup (Tx txbody _ _) = strictMaybeToMaybe (_txUpdate txbody)

shelley/chain-and-ledger/executable-spec/test/Test/Shelley/Spec/Ledger/Generator/Utxo.hs

@@ -99,6 +99,7 @@ import Test.Shelley.Spec.Ledger.Generator.Core
   )
 import Test.Shelley.Spec.Ledger.Generator.Delegation (CertCred (..))
 import Test.Shelley.Spec.Ledger.Generator.Trace.DCert (genDCerts)
+import Test.Shelley.Spec.Ledger.Generator.Update (genUpdate)
 
 -- | Generate a new transaction in the context of the LEDGER STS environment and state.
 --
@@ -114,14 +115,16 @@ genTx
   ge@( GenEnv
          KeySpace_
            { ksKeyPairs,
+             ksGenesisDelegates,
+             ksCoreNodes,
              ksIndexedPaymentKeys,
              ksIndexedStakingKeys,
              ksMSigScripts
            }
          constants
        )
   (LedgerEnv slot txIx pparams reserves)
-  (_utxoSt@(UTxOState utxo _ _ _), dpState) =
+  (utxoSt@(UTxOState utxo _ _ _), dpState) =
     do
       keys' <- QC.shuffle ksKeyPairs
       scripts' <- QC.shuffle ksMSigScripts
@@ -153,7 +156,7 @@ genTx
       let slotWithTTL = slot + SlotNo (fromIntegral ttl)
 
       -- certificates
-      (certs, certCreds, deposits_, refunds_, _dpState') <-
+      (certs, certCreds, deposits_, refunds_, dpState') <-
         genDCerts ge pparams dpState slot txIx reserves
 
       let balance_ = spendingBalance - deposits_ + refunds_
@@ -170,11 +173,8 @@ genTx
           let (_, outputs) = calcOutputsFromBalance balance_ recipientAddrs (Coin 0)
 
           --- PParam + AV Updates
-          -- TODO @uroboros Restore Updates to generated transactions,
-          -- see https://github.com/input-output-hk/cardano-ledger-specs/issues/1582
-          let (update, updateWitnesses) = (Nothing, []) :: (Maybe (Update h), [KeyPair h 'Witness])
-          -- (update, updateWitnesses) <-
-          --  genUpdate constants slot ksCoreNodes ((snd <$> ksCoreNodes) <> ksGenesisDelegates) pparams (utxoSt, dpState')
+          (update, updateWitnesses) <-
+            genUpdate constants slot ksCoreNodes ((snd <$> ksCoreNodes) <> ksGenesisDelegates) pparams (utxoSt, dpState')
 
           -- this is the "model" `TxBody` which is used to calculate the fees
           --