Merge #3340 #3341

3340: Update to cardano-node 1.35-rc3 r=Anviking a=sevanspowell I have: - Bumped the following dependencies to the `1.35.0-rc3` tag: - cardano-node - cardano-base - cardano-ledger - ouroboros-network - Updated cardano-wallet code to build with `1.35.0-rc3` tag: - `evaluateTransactionExecutionUnits` has a new error type, updated `ErrAssignRedeemers` accordingly. - `SimpleScriptWitness` now takes a `SimpleScriptOrReferenceInput` instead of a `SimpleScript`, updated generators accordingly. TODO: - [x] Consider whether the `prop_balanceTransactionUnresolvedInputs` test makes sense anymore. - [ ] Test the API output of `ErrAssignRedeemersTranslationError`. - [x] Update readme compatibility matrix ### Issue Number ADP-1907 3341: Light mode: reduce concurrency when retrieving data. r=Unisay a=Unisay - [x] Replace concurrent traversals with sequential ones in order to minimize likelihood of hitting `Too Many Requests` error. - [x] Fix bug with fetching Tx hashes for the same block multiple times. ### Comments Unfortunately the "Too Many Requests" error shows up anyway: [wallet.log](https://github.com/input-output-hk/cardano-wallet/files/8918830/wallet.log) ### Issue Number ADP-1651 Co-authored-by: Samuel Evans-Powell <[email protected]> Co-authored-by: Johannes Lund <[email protected]> Co-authored-by: Yuriy Lazaryev <[email protected]> Co-authored-by: Yura Lazarev <[email protected]>
cardano-foundation · Jun 20, 2022 · cf44db9 · cf44db9
3 parents 69ce334 + 700bf4b + c205888
commit cf44db9
Show file tree

Hide file tree

Showing 11 changed files with 232 additions and 143 deletions.
diff --git a/README.md b/README.md
@@ -71,7 +71,7 @@ See **Installation Instructions** for each available [release](https://github.co
 >
 > | cardano-wallet | cardano-node (compatible versions) | SMASH (compatible versions)
 > | --- | --- | ---
-> | `master` branch | [1.35.0-rc2](https://github.com/input-output-hk/cardano-node/releases/tag/1.35.0-rc2) | [1.6.1](https://github.com/input-output-hk/smash/releases/tag/1.6.1)
+> | `master` branch | [1.35.0-rc3](https://github.com/input-output-hk/cardano-node/releases/tag/1.35.0-rc3) | [1.6.1](https://github.com/input-output-hk/smash/releases/tag/1.6.1)
 > | [v2022-05-27](https://github.com/input-output-hk/cardano-wallet/releases/tag/v2022-05-27) | [1.34.1](https://github.com/input-output-hk/cardano-node/releases/tag/1.34.1) | [1.6.1](https://github.com/input-output-hk/smash/releases/tag/1.6.1)
 > | [v2022-04-27](https://github.com/input-output-hk/cardano-wallet/releases/tag/v2022-04-27) | [1.34.1](https://github.com/input-output-hk/cardano-node/releases/tag/1.34.1) | [1.6.1](https://github.com/input-output-hk/smash/releases/tag/1.6.1)
 > | [v2022-01-18](https://github.com/input-output-hk/cardano-wallet/releases/tag/v2022-01-18) | [1.33.0](https://github.com/input-output-hk/cardano-node/releases/tag/1.33.0) | [1.6.1](https://github.com/input-output-hk/smash/releases/tag/1.6.1)

diff --git a/cabal.project b/cabal.project
@@ -105,8 +105,8 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/input-output-hk/cardano-base
-    tag: 631cb6cf1fa01ab346233b610a38b3b4cba6e6ab
-    --sha256: 0944wg2nqazmhlmsynwgdwxxj6ay0hb9qig9l128isb2cjia0hlp
+    tag: 0f3a867493059e650cda69e20a5cbf1ace289a57
+    --sha256: 0p0az3sbkhb7njji8xxdrfb0yx2gc8fmrh872ffm8sfip1w29gg1
     subdir:
             base-deriving-via
             binary
@@ -154,8 +154,8 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/input-output-hk/cardano-ledger
-    tag: e290bf8d0ea272a51e9acd10adc96b4e12e00d37
-    --sha256: 1pmdg80a8irrqgdhbp46a9jx628mjbrj0k89xv5nb5dy37z5ig5f
+    tag: 52da70e5a0472cd4433876289f1aebaa0c6e5c85
+    --sha256: 0aiislbwx5yqdidwd66zqqpskvay84iwkgsgi5l96rbfcsf0n8lq
     subdir:
       eras/alonzo/impl
       eras/alonzo/test-suite
@@ -184,8 +184,8 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/input-output-hk/cardano-node
-    tag: 95c3692cfbd4cdb82071495d771b23e51840fb0e
-    --sha256: 1s4jjksz185dg4lp36ldha7vccxh0rk8zlvqms00zhg8kla21kr5
+    tag: 6471c31f8b61798df57a9f3345548703295cac9e
+    --sha256: 1xq2m40wgl6aw9zygzkvzcxxakcwd3p62q9j671r99i4c4x36z8g
     subdir:
       cardano-api
       cardano-git-rev
@@ -239,8 +239,8 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/input-output-hk/ouroboros-network
-    tag: 04245dbd69387da98d3a37de9f400965e922bb0e
-    --sha256: 0bgfclc7h441dwq9z69697nqfir6shj4358zxmwjiaifp93zkc2p
+    tag: a65c29b6a85e90d430c7f58d362b7eb097fd4949
+    --sha256: 1fmab5hmi1y8lss97xh6hhikmyhsx9x31yhvg6zpr2kcq7kc6qkf
     subdir:
       monoidal-synchronisation
       network-mux

diff --git a/lib/core/src/Cardano/Api/Gen.hs b/lib/core/src/Cardano/Api/Gen.hs
@@ -116,6 +116,7 @@ import Cardano.Api.Shelley
     , PoolId
     , ProtocolParameters (..)
     , ReferenceScript (..)
+    , SimpleScriptOrReferenceInput (..)
     , StakeCredential (..)
     , StakePoolMetadata (..)
     , StakePoolMetadataReference (..)
@@ -453,6 +454,17 @@ genSimpleScript lang =
         (Positive m) <- arbitrary
         genTerm (n `div` (m + 3))
 
+genReferenceInput :: Gen TxIn
+genReferenceInput = genTxIn
+
+genSimpleScriptOrReferenceInput
+    :: SimpleScriptVersion lang
+    -> Gen (SimpleScriptOrReferenceInput lang)
+genSimpleScriptOrReferenceInput lang =
+    oneof [ SScript <$> genSimpleScript lang
+          , SReferenceScript <$> genReferenceInput
+          ]
+
 genScript :: ScriptLanguage lang -> Gen (Script lang)
 genScript (SimpleScriptLanguage lang) =
     SimpleScript lang <$> genSimpleScript lang
@@ -690,7 +702,7 @@ genScriptWitnessMint
 genScriptWitnessMint langEra =
     case languageOfScriptLanguageInEra langEra of
         (SimpleScriptLanguage ver) ->
-            SimpleScriptWitness langEra ver <$> genSimpleScript ver
+            SimpleScriptWitness langEra ver <$> genSimpleScriptOrReferenceInput ver
         (PlutusScriptLanguage ver) ->
             PlutusScriptWitness langEra ver
             <$> genPlutusScriptOrReferenceInput ver
@@ -704,7 +716,7 @@ genScriptWitnessStake
 genScriptWitnessStake langEra =
     case languageOfScriptLanguageInEra langEra of
         (SimpleScriptLanguage ver) ->
-            SimpleScriptWitness langEra ver <$> genSimpleScript ver
+            SimpleScriptWitness langEra ver <$> genSimpleScriptOrReferenceInput ver
         (PlutusScriptLanguage ver) ->
             PlutusScriptWitness langEra ver
             <$> genPlutusScriptOrReferenceInput ver
@@ -718,7 +730,7 @@ genScriptWitnessSpend
 genScriptWitnessSpend langEra =
     case languageOfScriptLanguageInEra langEra of
         (SimpleScriptLanguage ver) ->
-            SimpleScriptWitness langEra ver <$> genSimpleScript ver
+            SimpleScriptWitness langEra ver <$> genSimpleScriptOrReferenceInput ver
         (PlutusScriptLanguage ver) ->
             PlutusScriptWitness langEra ver
             <$> genPlutusScriptOrReferenceInput ver

diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs
@@ -137,7 +137,8 @@ import Cardano.Api.Extra
 import Cardano.BM.Tracing
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Ledger.Alonzo.TxInfo
-    ( TranslationError (TimeTranslationPastHorizon) )
+    ( TranslationError (TimeTranslationPastHorizon, TranslationLogicMissingInput)
+    )
 import Cardano.Mnemonic
     ( SomeMnemonic )
 import Cardano.Wallet
@@ -5043,26 +5044,27 @@ instance IsServerError ErrAssignRedeemers where
                 , "for one of your redeemers since I am unable to decode it"
                 , "into a valid Plutus data:", pretty r <> "."
                 ]
-        ErrAssignRedeemersUnresolvedTxIns ins ->
-            -- Note that although this error is thrown from
-            -- '_assignScriptRedeemers', it's more related to balanceTransaction
-            -- in general than to assigning redeemers. Hence we don't mention
-            -- redeemers in the message.
-            apiError err400 UnresolvedInputs $ T.unwords
-                [ "The transaction I was given contains inputs I don't know"
-                , "about. Please ensure all foreign inputs are specified as "
-                , "part of the API request. The unknown inputs are:\n\n"
-                , pretty ins
-                ]
-        ErrAssignRedeemersTranslationError TimeTranslationPastHorizon ->
+        ErrAssignRedeemersTranslationError (TranslationLogicMissingInput inp) ->
+             -- Note that although this error is thrown from
+             -- '_assignScriptRedeemers', it's more related to balanceTransaction
+             -- in general than to assigning redeemers. Hence we don't mention
+             -- redeemers in the message.
+             apiError err400 UnresolvedInputs $ T.unwords
+                 [ "The transaction I was given contains inputs I don't know"
+                 , "about. Please ensure all foreign inputs are specified as "
+                 , "part of the API request. The unknown input is:\n\n"
+                 , T.pack $ show inp
+                 ]
+        ErrAssignRedeemersTranslationError (TimeTranslationPastHorizon t) ->
             -- We differentiate this from @TranslationError@ for partial API
             -- backwards compatibility.
             apiError err400 PastHorizon $ T.unwords
                 [ "The transaction's validity interval is past the horizon"
                 , "of safe slot-to-time conversions."
                 , "This may happen when I know about a future era"
                 , "which has not yet been confirmed on-chain. Try setting the"
-                , "bounds of the validity interval to be earlier."
+                , "bounds of the validity interval to be earlier.\n\n"
+                , "Here are the full details: " <> t
                 ]
         ErrAssignRedeemersTranslationError e ->
             apiError err400 TranslationError $ T.unwords

diff --git a/lib/core/src/Cardano/Wallet/Network/Light.hs b/lib/core/src/Cardano/Wallet/Network/Light.hs
@@ -1,14 +1,18 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
+
 module Cardano.Wallet.Network.Light
     ( -- * Interface
       LightSyncSource (..)
     , LightBlocks
     , hoistLightSyncSource
     , lightSync
-
+    , Consensual (..)
     , LightLayerLog (..)
     ) where
 
@@ -66,17 +70,15 @@ data LightSyncSource m block addr txs = LightSyncSource
     , isConsensus :: ChainPoint -> m Bool
         -- ^ Check whether a 'ChainPoint' still exists in the consensus,
         -- or whether the chain has rolled back already.
-    , getBlockHeaderAtHeight :: BlockHeight -> m (Maybe BlockHeader)
+    , getBlockHeaderAtHeight :: BlockHeight -> m (Consensual BlockHeader)
         -- ^ Get the 'BlockHeader' at a given block height.
-        -- Returns 'Nothing' if there is no block at this height (anymore).
-    , getNextBlockHeader :: BlockHeader -> m (Maybe BlockHeader)
+    , getNextBlockHeader :: BlockHeader -> m (Consensual (Maybe BlockHeader))
         -- ^ Get the next block header.
-    , getBlockHeaderAt :: ChainPoint -> m (Maybe BlockHeader)
+    , getBlockHeaderAt :: ChainPoint -> m (Consensual BlockHeader)
         -- ^ Get the full 'BlockHeader' belonging to a given 'ChainPoint'.
         -- Return 'Nothing' if the point is not consensus anymore.
-    , getNextBlocks :: ChainPoint -> m (Maybe [block])
+    , getNextBlocks :: ChainPoint -> m (Consensual [block])
         -- ^ Get several blocks immediately following the given 'Chainpoint'.
-        -- Return 'Nothing' if the point is not consensus anymore.
     , getAddressTxs :: BlockHeader -> BlockHeader -> addr -> m txs
         -- ^ Transactions for a given address and point range.
     }
@@ -94,7 +96,7 @@ hoistLightSyncSource f x = LightSyncSource
     , getNextBlockHeader = f . getNextBlockHeader x
     , getBlockHeaderAt = f . getBlockHeaderAt x
     , getNextBlocks = f . getNextBlocks x
-    , getAddressTxs = \a b c -> f $ getAddressTxs x a b c
+    , getAddressTxs = \a block c -> f $ getAddressTxs x a block c
     }
 
 type LightBlocks m block addr txs =
@@ -128,7 +130,7 @@ lightSync tr light follower = readChainPoints follower >>= syncFrom . latest
                 prev <- secondLatest <$> readChainPoints follower
                 -- NOTE: Rolling back to a result of 'readChainPoints'
                 -- should always be possible,
-                -- but the code here does not need this assumption.
+                -- but the code currently does not need this assumption.
                 traceWith tr $ MsgLightRollBackward chainPoint prev
                 rollBackward follower prev
             Stable old new tip -> do
@@ -139,9 +141,9 @@ lightSync tr light follower = readChainPoints follower >>= syncFrom . latest
             Unstable blocks new tip -> do
                 case blocks of
                     [] -> threadDelay secondsPerSlot
-                    b : bs -> do
+                    block : bs -> do
                         traceWith tr $ MsgLightRollForward chainPoint new tip
-                        rollForward follower (Left $ b :| bs) tip
+                        rollForward follower (Left $ block :| bs) tip
                 pure $ chainPointFromBlockHeader new
 
 data NextPointMove block
@@ -154,35 +156,54 @@ data NextPointMove block
     -- ^ We are entering the unstable region.
     -- @Unstable blocks new tip@.
 
+-- | 'Consensual' represents the result of query on the blockchain.
+-- Either the result is a value that is part of the consensus chain,
+-- or the result is an indication that the consensus had changed
+-- before the entire value could be retrieved.
+data Consensual a
+    = NotConsensual
+    | Consensual a
+    deriving stock (Eq, Show, Functor, Foldable, Traversable)
+
+consensually
+    :: Applicative m
+    => Consensual a
+    -> (a -> m (NextPointMove block))
+    -> m (NextPointMove block)
+consensually ca k =
+    case ca of
+        NotConsensual-> pure Rollback
+        Consensual a -> k a
+
 proceedToNextPoint
     :: Monad m
     => LightSyncSource m block addr txs
     -> ChainPoint
     -> m (NextPointMove block)
 proceedToNextPoint light chainPoint = do
     tip <- getTip light
-    mhere <- getBlockHeaderAt light chainPoint
-    maybeRollback mhere $ \here ->
-        if isUnstable (stabilityWindow light) here tip
+    currentBlockHeader <- getBlockHeaderAt light chainPoint
+    consensually currentBlockHeader \current ->
+        if isUnstable (stabilityWindow light) current tip
         then do
-            mblocks <- getNextBlocks light chainPoint
-            maybeRollback mblocks $ \case
-                [] -> pure $ Unstable [] here tip
-                b : bs -> do
-                    let new = getHeader light $ NE.last (b :| bs)
+            nextBlocks <- getNextBlocks light chainPoint
+            consensually nextBlocks \case
+                [] -> pure $ Unstable [] current tip
+                block : blocks -> do
+                    let new = getHeader light $ NE.last (block :| blocks)
                     continue <- isConsensus light $ chainPointFromBlockHeader new
                     pure $ if continue
-                        then Unstable (b:bs) new tip
+                        then Unstable (block : blocks) new tip
                         else Rollback
         else do
-            mold <- getNextBlockHeader light here
-            mnew <- getBlockHeaderAtHeight light $
+            frBlockHeader <- getNextBlockHeader light current
+            toBlockHeader <- getBlockHeaderAtHeight light $
                 blockHeightToInteger (blockHeight tip) - stabilityWindow light
-            maybeRollback mold $ \old ->
-                maybeRollback mnew $ \new ->
-                    pure $ Stable old new tip
-  where
-    maybeRollback m f = maybe (pure Rollback) f m
+            consensually frBlockHeader \case
+                Nothing -> pure $ Unstable [] current tip
+                Just fromBH ->
+                    consensually toBlockHeader \toBH ->
+                        pure $ Stable fromBH toBH tip
 
 -- | Test whether a 'ChainPoint' is in the
 -- unstable region close to the tip.

diff --git a/lib/core/src/Cardano/Wallet/Transaction.hs b/lib/core/src/Cardano/Wallet/Transaction.hs
@@ -59,6 +59,8 @@ import Cardano.Api
     ( AnyCardanoEra )
 import Cardano.Ledger.Alonzo.TxInfo
     ( TranslationError )
+import Cardano.Ledger.Crypto
+    ( StandardCrypto )
 import Cardano.Wallet.CoinSelection
     ( SelectionCollateralRequirement (..)
     , SelectionLimit
@@ -508,9 +510,7 @@ data ErrAssignRedeemers
     -- ^ The given redeemer target couldn't be located in the transaction.
     | ErrAssignRedeemersInvalidData Redeemer String
     -- ^ Redeemer's data isn't a valid Plutus' data.
-    | ErrAssignRedeemersUnresolvedTxIns [TxIn]
-    -- ^ The transaction contains inputs which couldn't be resolved.
-    | ErrAssignRedeemersTranslationError TranslationError
+    | ErrAssignRedeemersTranslationError (TranslationError StandardCrypto)
     -- ^ Mistranslating of hashes, credentials, certificates etc.
     deriving (Generic, Eq, Show)
 

diff --git a/lib/core/test/unit/Cardano/Wallet/Network/LightSpec.hs b/lib/core/test/unit/Cardano/Wallet/Network/LightSpec.hs
@@ -12,7 +12,12 @@ import Prelude
 import Cardano.Wallet.Network
     ( ChainFollower (..) )
 import Cardano.Wallet.Network.Light
-    ( LightBlocks, LightSyncSource (..), hoistLightSyncSource, lightSync )
+    ( Consensual (Consensual, NotConsensual)
+    , LightBlocks
+    , LightSyncSource (..)
+    , hoistLightSyncSource
+    , lightSync
+    )
 import Cardano.Wallet.Primitive.BlockSummary
     ( BlockSummary (..) )
 import Cardano.Wallet.Primitive.Types
@@ -98,17 +103,17 @@ mkLightSyncSourceMock = LightSyncSource
     , getTip = NE.head
     , isConsensus = \pt -> any ((pt ==) . toPoint)
     , getBlockHeaderAtHeight = \height ->
-        find ((height ==) . toHeight)
+        maybe NotConsensual Consensual . find ((height ==) . toHeight)
     , getBlockHeaderAt = \pt ->
-        find ((pt ==) . toPoint)
+        maybe NotConsensual Consensual . find ((pt ==) . toPoint)
     , getNextBlocks = \pt chain ->
         case NE.span ((pt /=) . toPoint) chain of
-            (_, []) -> Nothing -- point does not exist
-            (xs, _) -> Just (reverse xs)
+            (_, []) -> NotConsensual
+            (xs, _) -> Consensual (reverse xs)
     , getNextBlockHeader = \bh chain ->
         case NE.span (bh /=) chain of
-            (_, []) -> Nothing -- point does not exist
-            (xs, _) -> listToMaybe (reverse xs)
+            (_, []) -> NotConsensual
+            (xs, _) -> Consensual $ listToMaybe $ reverse xs
     , getAddressTxs = \_ _ _ -> pure ()
     }
   where