Try #3071:

cardano-foundation · Jan 7, 2022 · e7963e1 · e7963e1
2 parents d19fafe + 852adff
commit e7963e1
Show file tree

Hide file tree

Showing 139 changed files with 24,871 additions and 20,786 deletions.
diff --git a/README.md b/README.md
@@ -69,7 +69,7 @@ See **Installation Instructions** for each available [release](https://github.co
 >
 > | cardano-wallet | cardano-node (compatible versions) | SMASH (compatible versions)
 > | --- | --- | ---
-> | `master` branch | [1.32.1](https://github.com/input-output-hk/cardano-node/releases/tag/1.32.1) | [1.6.1](https://github.com/input-output-hk/smash/releases/tag/1.6.1)
+> | `master` branch | [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)
 > | [v2021-12-15](https://github.com/input-output-hk/cardano-wallet/releases/tag/v2021-12-15) | [1.32.1](https://github.com/input-output-hk/cardano-node/releases/tag/1.32.1) | [1.6.1](https://github.com/input-output-hk/smash/releases/tag/1.6.1)
 > | [v2021-11-11](https://github.com/input-output-hk/cardano-wallet/releases/tag/v2021-11-11) | [1.30.1](https://github.com/input-output-hk/cardano-node/releases/tag/1.30.1) | [1.6.1](https://github.com/input-output-hk/smash/releases/tag/1.6.1)
 > | [v2021-09-29](https://github.com/input-output-hk/cardano-wallet/releases/tag/v2021-09-29) | [1.30.1](https://github.com/input-output-hk/cardano-node/releases/tag/1.30.1) | [1.6.0](https://github.com/input-output-hk/smash/releases/tag/1.6.0)

diff --git a/cabal.project b/cabal.project
@@ -38,7 +38,7 @@
 --
 --------------------------------------------------------------------------------
 
-index-state: 2021-12-01T00:00:00Z
+index-state: 2022-01-01T00:00:00Z
 with-compiler: ghc-8.10.7
 
 packages:
@@ -81,7 +81,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/input-output-hk/cardano-base
-    tag: e8a48cf0500b03c744c7fc6f2fedb86e8bdbe055
+    tag: 41545ba3ac6b3095966316a99883d678b5ab8da8
     subdir:
             base-deriving-via
             binary
@@ -127,7 +127,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/input-output-hk/cardano-ledger
-    tag: bf008ce028751cae9fb0b53c3bef20f07c06e333
+    tag: 1a9ec4ae9e0b09d54e49b2a40c4ead37edadcce5
     subdir:
       eras/alonzo/impl
       eras/alonzo/test-suite
@@ -144,17 +144,17 @@ source-repository-package
       libs/cardano-ledger-core
       libs/cardano-ledger-pretty
       libs/cardano-protocol-tpraos
+      libs/cardano-data
+      libs/compact-map
+      libs/set-algebra
       libs/small-steps
       libs/small-steps-test
       libs/non-integral
-      eras/shelley/chain-and-ledger/executable-spec
-      eras/shelley/chain-and-ledger/shelley-spec-ledger-test
-      eras/shelley/chain-and-ledger/dependencies/non-integer
 
 source-repository-package
     type: git
     location: https://github.com/input-output-hk/cardano-node
-    tag: 4f65fb9a27aa7e3a1873ab4211e412af780a3648
+    tag: 814df2c146f5d56f8c35a681fe75e85b905aed5d
     subdir:
       cardano-api
       cardano-cli
@@ -196,7 +196,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/input-output-hk/ouroboros-network
-    tag: d613de3d872ec8b4a5da0c98afb443f322dc4dab
+    tag: d2d219a86cda42787325bb8c20539a75c2667132
     subdir:
       io-sim
       io-classes
@@ -205,10 +205,12 @@ source-repository-package
       ouroboros-consensus
       ouroboros-consensus-byron
       ouroboros-consensus-cardano
+      ouroboros-consensus-protocol
       ouroboros-consensus-shelley
       ouroboros-network
       ouroboros-network-framework
       ouroboros-network-testing
+      strict-stm
       typed-protocols
       typed-protocols-cborg
       typed-protocols-examples

diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal
@@ -115,14 +115,14 @@ library
     , servant
     , servant-client
     , servant-server
-    , shelley-spec-ledger
-    , shelley-spec-ledger-test
     , split
     , splitmix
     , statistics
+    , stm
     , streaming-commons
     , strict-containers
     , strict-non-empty-containers
+    , strict-stm
     , string-interpolate
     , template-haskell
     , text
@@ -356,7 +356,6 @@ test-suite unit
     , plutus-ledger-api
     , pretty-simple
     , regex-pcre-builtin
-    , shelley-spec-ledger
     , OddWord
     , ouroboros-consensus
     , QuickCheck
@@ -369,7 +368,6 @@ test-suite unit
     , scrypt
     , servant
     , servant-server
-    , shelley-spec-ledger-test
     , should-not-typecheck
     , splitmix
     , strict-non-empty-containers

diff --git a/lib/core/src/Cardano/Api/Gen.hs b/lib/core/src/Cardano/Api/Gen.hs
@@ -143,7 +143,7 @@ import Data.String
 import Data.Text
     ( Text )
 import Data.Word
-    ( Word64 )
+    ( Word16, Word32, Word64 )
 import Network.Socket
     ( PortNumber )
 import Numeric.Natural
@@ -212,9 +212,16 @@ genTxId :: Gen TxId
 genTxId = TxId <$> genShelleyHash
 
 genTxIndex :: Gen TxIx
-genTxIndex = do
-    (Large (n :: Word)) <- arbitrary
-    pure $ TxIx n
+genTxIndex = frequency
+    [ ( 45, do
+          -- 2 ^ 32 - 1 is the upper limit on TxIxs in the Byron era
+          n <- chooseInteger (0, fromIntegral $ ((2 :: Word32) ^ (32 :: Word32)) - 1)
+          pure $ TxIx $ fromIntegral n
+      )
+    -- Make sure to choose some small values too
+    , ( 45, (TxIx . fromIntegral) <$> chooseInteger (0, fromIntegral (maxBound :: Word16)) )
+    , ( 10, pure $ TxIx 0 )
+    ]
 
 genTxInsCollateral :: CardanoEra era -> Gen (TxInsCollateral era)
 genTxInsCollateral era =
@@ -968,7 +975,8 @@ genStakePoolMetadata =
 
         genDescription :: Gen T.Text
         genDescription = do
-            n <- arbitrary
+            -- There is a overall limit of 512 bytes for metadata
+            n <- chooseInt (0, 64)
             T.pack <$> vector n
 
         genTicker :: Gen T.Text
@@ -1227,6 +1235,7 @@ genTxBodyContent era = do
             }
 
     let witnesses = collectTxBodyScriptWitnesses txBody
+    -- No use of a script language means no need for collateral
     if Set.null (languages witnesses)
     then do
         pparams <- BuildTxWith <$> liftArbitrary genProtocolParameters

diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs
@@ -4246,6 +4246,17 @@ 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
+                ]
         ErrAssignRedeemersPastHorizon e ->
             toServerError e
 

diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs
@@ -1659,6 +1659,7 @@ data ApiErrorCode
     | TransactionAlreadyBalanced
     | RedeemerScriptFailure
     | RedeemerTargetNotFound
+    | UnresolvedInputs
     | RedeemerInvalidData
     | ExistingKeyWitnesses
     deriving (Eq, Generic, Show, Data, Typeable)

diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite/CheckpointsOld.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite/CheckpointsOld.hs
@@ -2,16 +2,21 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 -- |
 -- Copyright: © 2021 IOHK
 -- License: Apache-2.0
@@ -96,14 +101,22 @@ import Cardano.Wallet.Primitive.Types.TokenMap
     ( AssetId (..) )
 import Cardano.Wallet.Util
     ( invariant )
+import Control.Applicative
+    ( Alternative )
 import Control.Monad
-    ( forM, forM_, unless, void, when )
+    ( MonadPlus, forM, forM_, unless, void, when )
+import Control.Monad.Class.MonadSTM
+    ( MonadSTM (..) )
+import Control.Monad.IO.Class
+    ( MonadIO (..) )
 import Control.Monad.Trans.Class
     ( lift )
 import Control.Monad.Trans.Except
     ( ExceptT (..), runExceptT )
 import Control.Monad.Trans.Maybe
     ( MaybeT (..) )
+import Control.Monad.Trans.Reader
+    ( ReaderT (..) )
 import Data.Bifunctor
     ( bimap, second )
 import Data.DBVar
@@ -129,6 +142,7 @@ import Data.Typeable
 import Database.Persist.Sql
     ( Entity (..)
     , SelectOpt (..)
+    , SqlBackend
     , deleteWhere
     , insertMany_
     , insert_
@@ -156,6 +170,11 @@ import qualified Cardano.Wallet.Primitive.Types.Coin as W
 import qualified Cardano.Wallet.Primitive.Types.TokenBundle as TokenBundle
 import qualified Cardano.Wallet.Primitive.Types.Tx as W
 import qualified Cardano.Wallet.Primitive.Types.UTxO as W
+import qualified Control.Concurrent.STM.TBQueue as STM
+import qualified Control.Concurrent.STM.TMVar as STM
+import qualified Control.Concurrent.STM.TQueue as STM
+import qualified Control.Concurrent.STM.TVar as STM
+import qualified Control.Monad.STM as STM
 import qualified Data.Map.Merge.Strict as Map
 import qualified Data.Map.Strict as Map
 
@@ -172,7 +191,7 @@ mkStoreWalletsCheckpoints = Store{loadS=load,writeS=write,updateS=update}
     write = error "mkStoreWalletsCheckpoints: not implemented"
 
     update _ (Insert wid a) =
-        writeS (mkStoreCheckpoints wid) a 
+        writeS (mkStoreCheckpoints wid) a
     update _ (Delete wid) = do
         -- FIXME LATER during ADP-1043:
         --  Deleting an entry in the Checkpoint table
@@ -377,7 +396,7 @@ class AddressBookIso s => PersistAddressBook s where
         :: W.WalletId -> Prologue s -> SqlPersistT IO ()
     insertDiscoveries
         :: W.WalletId -> W.SlotNo -> Discoveries s -> SqlPersistT IO ()
-    
+
     loadPrologue
         :: W.WalletId -> SqlPersistT IO (Maybe (Prologue s))
     loadDiscoveries
@@ -491,7 +510,7 @@ instance
     , WalletKey key
     , key ~ SharedKey
     ) => PersistAddressBook (Shared.SharedState n key) where
-    
+
     insertPrologue wid (SharedPrologue st) = do
         let Shared.SharedState prefix accXPub pTemplate dTemplateM gap _ = st
         insertSharedState prefix accXPub gap pTemplate dTemplateM
@@ -652,3 +671,68 @@ selectRndStatePending wid = do
   where
     assocFromEntity (RndStatePendingAddress _ accIx addrIx addr) =
         ((W.Index accIx, W.Index addrIx), addr)
+
+{-------------------------------------------------------------------------------
+                     Provide ReaderT instance for MonadSTM
+-------------------------------------------------------------------------------}
+
+instance MonadSTM (ReaderT SqlBackend IO) where
+    type STM (ReaderT SqlBackend IO) = WrapSTM
+    atomically = liftIO . STM.atomically . unWrapSTM
+
+    type TVar (ReaderT SqlBackend IO) = TVar IO
+    type TMVar (ReaderT SqlBackend IO) = TMVar IO
+    type TBQueue (ReaderT SqlBackend IO) = TBQueue IO
+    type TQueue (ReaderT SqlBackend IO) = TQueue IO
+
+    newTVar        =       WrapSTM . STM.newTVar
+    readTVar       =       WrapSTM . STM.readTVar
+    writeTVar      = \v -> WrapSTM . STM.writeTVar v
+    retry          = WrapSTM STM.retry
+    orElse         = \(WrapSTM a) (WrapSTM b) -> WrapSTM (STM.orElse a b)
+    modifyTVar     = \v -> WrapSTM . STM.modifyTVar v
+    modifyTVar'    = \v -> WrapSTM . STM.modifyTVar' v
+    stateTVar      = \v -> WrapSTM . STM.stateTVar v
+    swapTVar       = \v -> WrapSTM . STM.swapTVar v
+    check          =       WrapSTM . STM.check
+    newTMVar       =       WrapSTM . STM.newTMVar
+    newEmptyTMVar  =       WrapSTM STM.newEmptyTMVar
+    takeTMVar      =       WrapSTM . STM.takeTMVar
+    tryTakeTMVar   =       WrapSTM . STM.tryTakeTMVar
+    putTMVar       = \v -> WrapSTM . STM.putTMVar v
+    tryPutTMVar    = \v -> WrapSTM . STM.tryPutTMVar v
+    readTMVar      =       WrapSTM . STM.readTMVar
+    tryReadTMVar   =       WrapSTM . STM.tryReadTMVar
+    swapTMVar      = \v -> WrapSTM . STM.swapTMVar v
+    isEmptyTMVar   =       WrapSTM . STM.isEmptyTMVar
+    newTQueue      =       WrapSTM STM.newTQueue
+    readTQueue     =       WrapSTM . STM.readTQueue
+    tryReadTQueue  =       WrapSTM . STM.tryReadTQueue
+    peekTQueue     =       WrapSTM . STM.peekTQueue
+    tryPeekTQueue  =       WrapSTM . STM.tryPeekTQueue
+    flushTBQueue   =       WrapSTM . STM.flushTBQueue
+    writeTQueue    = \q -> WrapSTM . STM.writeTQueue q
+    isEmptyTQueue  =       WrapSTM . STM.isEmptyTQueue
+    newTBQueue     =       WrapSTM . STM.newTBQueue
+    readTBQueue    =       WrapSTM . STM.readTBQueue
+    tryReadTBQueue =       WrapSTM . STM.tryReadTBQueue
+    peekTBQueue    =       WrapSTM . STM.peekTBQueue
+    tryPeekTBQueue =       WrapSTM . STM.tryPeekTBQueue
+    writeTBQueue   = \q -> WrapSTM . STM.writeTBQueue q
+    lengthTBQueue  =       WrapSTM . STM.lengthTBQueue
+    isEmptyTBQueue =       WrapSTM . STM.isEmptyTBQueue
+    isFullTBQueue  =       WrapSTM . STM.isFullTBQueue
+
+    newTVarIO       = liftIO . STM.newTVarIO
+    readTVarIO      = liftIO . STM.readTVarIO
+    newTMVarIO      = liftIO . STM.newTMVarIO
+    newEmptyTMVarIO = liftIO STM.newEmptyTMVarIO
+    newTQueueIO     = liftIO STM.newTQueueIO
+    newTBQueueIO    = liftIO . STM.newTBQueueIO
+
+-- | MonadSTM is an injective typeclass, so we need a unique newtype to target.
+newtype WrapSTM a = WrapSTM { unWrapSTM :: STM.STM a }
+    deriving (Applicative, Functor, Monad)
+
+deriving instance MonadPlus WrapSTM
+deriving instance Alternative WrapSTM
diff --git a/lib/core/src/Cardano/Wallet/Transaction.hs b/lib/core/src/Cardano/Wallet/Transaction.hs
@@ -330,6 +330,8 @@ data ErrAssignRedeemers
     -- ^ Redeemer's data isn't a valid Plutus' data.
     | ErrAssignRedeemersPastHorizon PastHorizonException
     -- ^ Evaluating the Plutus script failed past the visible horizon.
+    | ErrAssignRedeemersUnresolvedTxIns [TxIn]
+    -- ^ The transaction contains inputs which couldn't be resolved.
     deriving (Generic, Eq, Show)
 
 -- | Possible signing error