Merge #2896

2896: Change SealedTx to have dual representations, stub signTx endpoint r=rvl a=rvl

This improves the `SealedTx` type so that it can be used in either bytestring or Cardano.Tx form, whichever is more convenient.

### Comments

A couple tests needed to be disabled for this change to be separated from PR #2754, but they will be put back in a later PR.

Based on the PR #2895 branch - merge that first.

### Issue Number

ADP-919


Co-authored-by: Rodney Lorrimar <rodney.lorrimar@iohk.io>
Co-authored-by: Pawel Jakubas <pawel.jakubas@iohk.io>

lib/core/cardano-wallet-core.cabal

@@ -39,6 +39,7 @@ library
     , bytestring
     , cardano-addresses
     , cardano-api
+    , cardano-binary
     , cardano-crypto
     , cardano-numeric
     , cardano-ledger-core
@@ -271,6 +272,7 @@ test-suite unit
     , cardano-api
     , cardano-binary
     , cardano-crypto
+    , cardano-crypto-class
     , cardano-numeric
     , cardano-ledger-byron
     , cardano-ledger-byron-test
@@ -408,6 +410,7 @@ test-suite unit
       Cardano.Wallet.Primitive.Types.TokenMapSpec.TypeErrorSpec
       Cardano.Wallet.Primitive.Types.TokenPolicySpec
       Cardano.Wallet.Primitive.Types.TokenQuantitySpec
+      Cardano.Wallet.Primitive.Types.TxSpec
       Cardano.Wallet.Primitive.Types.UTxOSpec
       Cardano.Wallet.Primitive.Types.UTxOIndexSpec
       Cardano.Wallet.Primitive.Types.UTxOIndex.TypeErrorSpec

lib/core/src/Cardano/Wallet.hs

@@ -136,10 +136,7 @@ module Cardano.Wallet
     , quitStakePool
     , guardJoin
     , guardQuit
-    , ErrJoinStakePool (..)
-    , ErrCannotJoin (..)
-    , ErrQuitStakePool (..)
-    , ErrCannotQuit (..)
+    , ErrStakePoolDelegation (..)
 
     -- ** Fee Estimation
     , FeeEstimation (..)
@@ -156,16 +153,15 @@ module Cardano.Wallet
     , LocalTxSubmissionConfig (..)
     , defaultLocalTxSubmissionConfig
     , runLocalTxSubmissionPool
-    , ErrMkTx (..)
+    , ErrMkTransaction (..)
     , ErrSubmitTx (..)
-    , ErrSubmitExternalTx (..)
     , ErrRemoveTx (..)
     , ErrPostTx (..)
-    , ErrDecodeSignedTx (..)
     , ErrListTransactions (..)
     , ErrGetTransaction (..)
     , ErrNoSuchTransaction (..)
     , ErrStartTimeLaterThanEndTime (..)
+    , ErrWitnessTx (..)
 
     -- ** Root Key
     , withRootKey
@@ -376,8 +372,6 @@ import Cardano.Wallet.Primitive.Types.Tx
     ( Direction (..)
     , LocalTxSubmissionStatus
     , SealedTx (..)
-    , SerialisedTx (..)
-    , SerialisedTxParts (..)
     , TransactionInfo (..)
     , Tx
     , TxChange (..)
@@ -397,8 +391,10 @@ import Cardano.Wallet.Primitive.Types.UTxOIndex
     ( UTxOIndex )
 import Cardano.Wallet.Transaction
     ( DelegationAction (..)
-    , ErrDecodeSignedTx (..)
-    , ErrMkTx (..)
+    , ErrCannotJoin (..)
+    , ErrCannotQuit (..)
+    , ErrMkTransaction (..)
+    , ErrSignTx (..)
     , TransactionCtx (..)
     , TransactionLayer (..)
     , Withdrawal (..)
@@ -485,9 +481,10 @@ import Data.Void
 import Data.Word
     ( Word64 )
 import Fmt
-    ( Buildable (..)
+    ( Buildable
     , blockListF
     , blockMapF
+    , build
     , nameF
     , pretty
     , unlinesF
@@ -575,7 +572,7 @@ data WalletLayer m s (k :: Depth -> Type -> Type)
         (Tracer m WalletWorkerLog)
         (Block, NetworkParameters, SyncTolerance)
         (NetworkLayer m Block)
-        (TransactionLayer k)
+        (TransactionLayer k SealedTx)
         (DBLayer m s k)
     deriving (Generic)
 
@@ -619,7 +616,7 @@ type HasLogger msg = HasType (Tracer IO msg)
 -- hides that choice, for some ease of use.
 type HasNetworkLayer m = HasType (NetworkLayer m Block)
 
-type HasTransactionLayer k = HasType (TransactionLayer k)
+type HasTransactionLayer k = HasType (TransactionLayer k SealedTx)
 
 dbLayer
     :: forall m s k ctx. HasDBLayer m s k ctx
@@ -647,9 +644,9 @@ networkLayer =
 
 transactionLayer
     :: forall k ctx. (HasTransactionLayer k ctx)
-    => Lens' ctx (TransactionLayer k)
+    => Lens' ctx (TransactionLayer k SealedTx)
 transactionLayer =
-    typed @(TransactionLayer k)
+    typed @(TransactionLayer k SealedTx)
 
 {-------------------------------------------------------------------------------
                                    Wallet
@@ -1578,40 +1575,16 @@ selectAssets ctx (utxoAvailable, cp, pending) txCtx outputs transform = do
         hasWithdrawal = not . null . withdrawals
 
 signTransaction
-    :: forall ctx s k.
-        ( HasTransactionLayer k ctx
-        , HasDBLayer IO s k ctx
-        , HasNetworkLayer IO ctx
-        , IsOwned s k
-        )
-    => ctx
+    :: ctx
     -> WalletId
     -> ((k 'RootK XPrv, Passphrase "encryption") -> (XPrv, Passphrase "encryption"))
        -- ^ Reward account derived from the root key (or somewhere else).
     -> Passphrase "raw"
-    -> ByteString
-    -> ExceptT ErrSignPayment IO SerialisedTxParts
-signTransaction ctx wid mkRwdAcct pwd txBody = db & \DBLayer{..} -> do
-    era <- liftIO $ currentNodeEra nl
-    let _decoded = decodeSignedTx tl era txBody
-    withRootKey @_ @s ctx wid pwd ErrSignPaymentWithRootKey $ \xprv scheme -> do
-        let pwdP = preparePassphrase scheme pwd
-        mapExceptT atomically $ do
-            cp <- withExceptT ErrSignPaymentNoSuchWallet $ withNoSuchWallet wid $
-                readCheckpoint wid
-
-            -- TODO: ADP-919 implement this
-            let _keyFrom = isOwned (getState cp) (xprv, pwdP)
-            let _rewardAcnt = mkRwdAcct (xprv, pwdP)
-            -- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
-            --     witnessTransaction tl rewardAcnt keyFrom txBody
-            let tx = mempty
-            pure $ SerialisedTxParts tx txBody []
-
-  where
-    db = ctx ^. dbLayer @IO @s @k
-    tl = ctx ^. transactionLayer @k
-    nl = ctx ^. networkLayer
+    -> SealedTx
+    -> ExceptT ErrWitnessTx IO SealedTx
+signTransaction _ctx _wid _mkRwdAcct _pwd _tx =
+    -- TODO: [ADP-919] implement Wallet.signTransaction
+    throwE (ErrWitnessTxSignTx ErrSignTxUnimplemented)
 
 -- | Produce witnesses and construct a transaction from a given selection.
 --
@@ -1672,15 +1645,14 @@ constructTransaction
     -> WalletId
     -> TransactionCtx
     -> SelectionResult TxOut
-    -> ExceptT ErrConstructTx IO SerialisedTx
-constructTransaction ctx wid txCtx sel =
-    db & \DBLayer{..} -> do
+    -> ExceptT ErrConstructTx IO SealedTx
+constructTransaction ctx wid txCtx sel = db & \DBLayer{..} -> do
     era <- liftIO $ currentNodeEra nl
     (_, xpub, _) <- withExceptT ErrConstructTxReadRewardAccount $
         readRewardAccount @ctx @s @k @n ctx wid
     mapExceptT atomically $ do
         pp <- liftIO $ currentProtocolParameters nl
-        withExceptT ErrConstructTxMkTx $ ExceptT $ pure $
+        withExceptT ErrConstructTxBody $ ExceptT $ pure $
             mkUnsignedTransaction tl era xpub pp txCtx sel
   where
     db = ctx ^. dbLayer @IO @s @k
@@ -1804,19 +1776,16 @@ submitExternalTx
         , HasLogger TxSubmitLog ctx
         )
     => ctx
-    -> ByteString
-    -> ExceptT ErrSubmitExternalTx IO Tx
-submitExternalTx ctx bytes = do
-    era <- liftIO $ currentNodeEra nw
-    (tx, binary) <- withExceptT ErrSubmitExternalTxDecode $ except $
-        decodeSignedTx tl era bytes
-    withExceptT ErrSubmitExternalTxNetwork $ traceResult (trPost tx) $ do
-        postTx nw binary
-        pure tx
+    -> SealedTx
+    -> ExceptT ErrPostTx IO Tx
+submitExternalTx ctx sealedTx = traceResult trPost $ do
+    postTx nw sealedTx
+    pure tx
   where
-    nw = ctx ^. networkLayer
     tl = ctx ^. transactionLayer @k
-    trPost tx = contramap (MsgSubmitExternalTx (tx ^. #txId)) (ctx ^. logger)
+    nw = ctx ^. networkLayer
+    trPost = contramap (MsgSubmitExternalTx (tx ^. #txId)) (ctx ^. logger)
+    tx = decodeTx tl sealedTx
 
 -- | Remove a pending or expired transaction from the transaction history. This
 -- happens at the request of the user. If the transaction is already on chain,
@@ -2107,15 +2076,15 @@ joinStakePool
     -> PoolId
     -> PoolLifeCycleStatus
     -> WalletId
-    -> ExceptT ErrJoinStakePool IO (DelegationAction, Maybe Coin)
+    -> ExceptT ErrStakePoolDelegation IO (DelegationAction, Maybe Coin)
     -- ^ snd is the deposit
 joinStakePool ctx currentEpoch knownPools pid poolStatus wid =
     db & \DBLayer{..} -> do
         (walMeta, isKeyReg) <- mapExceptT atomically $ do
-            walMeta <- withExceptT ErrJoinStakePoolNoSuchWallet
+            walMeta <- withExceptT ErrStakePoolDelegationNoSuchWallet
                 $ withNoSuchWallet wid
                 $ readWalletMeta wid
-            isKeyReg <- withExceptT ErrJoinStakePoolNoSuchWallet
+            isKeyReg <- withExceptT ErrStakePoolDelegationNoSuchWallet
                 $ isStakeKeyRegistered wid
             pure (walMeta, isKeyReg)
 
@@ -2124,7 +2093,7 @@ joinStakePool ctx currentEpoch knownPools pid poolStatus wid =
         let retirementInfo =
                 PoolRetirementEpochInfo currentEpoch <$> mRetirementEpoch
 
-        withExceptT ErrJoinStakePoolCannotJoin $ except $
+        withExceptT ErrStakePoolJoin $ except $
             guardJoin knownPools (walMeta ^. #delegation) pid retirementInfo
 
         liftIO $ traceWith tr $ MsgIsStakeKeyRegistered isKeyReg
@@ -2147,17 +2116,17 @@ quitStakePool
         )
     => ctx
     -> WalletId
-    -> ExceptT ErrQuitStakePool IO DelegationAction
+    -> ExceptT ErrStakePoolDelegation IO DelegationAction
 quitStakePool ctx wid = db & \DBLayer{..} -> do
     walMeta <- mapExceptT atomically
-        $ withExceptT ErrQuitStakePoolNoSuchWallet
+        $ withExceptT ErrStakePoolDelegationNoSuchWallet
         $ withNoSuchWallet wid
         $ readWalletMeta wid
 
     rewards <- liftIO
         $ fetchRewardBalance @ctx @s @k ctx wid
 
-    withExceptT ErrQuitStakePoolCannotQuit $ except $
+    withExceptT ErrStakePoolQuit $ except $
         guardQuit (walMeta ^. #delegation) rewards
 
     pure Quit
@@ -2620,7 +2589,7 @@ newtype ErrListUTxOStatistics
 
 -- | Errors that can occur when signing a transaction.
 data ErrSignPayment
-    = ErrSignPaymentMkTx ErrMkTx
+    = ErrSignPaymentMkTx ErrMkTransaction
     | ErrSignPaymentNoSuchWallet ErrNoSuchWallet
     | ErrSignPaymentWithRootKey ErrWithRootKey
     | ErrSignPaymentIncorrectTTL PastHorizonException
@@ -2629,7 +2598,7 @@ data ErrSignPayment
 -- | Errors that can occur when constructing an unsigned transaction.
 data ErrConstructTx
     = ErrConstructTxWrongPayload
-    | ErrConstructTxMkTx ErrMkTx
+    | ErrConstructTxBody ErrMkTransaction
     | ErrConstructTxNoSuchWallet ErrNoSuchWallet
     | ErrConstructTxReadRewardAccount ErrReadRewardAccount
     | ErrConstructTxIncorrectTTL PastHorizonException
@@ -2642,20 +2611,21 @@ newtype ErrMintBurnAssets
       -- ^ Temporary error constructor.
     deriving (Show, Eq)
 
+-- | Errors that can occur when signing a transaction.
+data ErrWitnessTx
+    = ErrWitnessTxSignTx ErrSignTx
+    | ErrWitnessTxNoSuchWallet ErrNoSuchWallet
+    | ErrWitnessTxWithRootKey ErrWithRootKey
+    | ErrWitnessTxIncorrectTTL PastHorizonException
+    deriving (Show, Eq)
+
 -- | Errors that can occur when submitting a signed transaction to the network.
 data ErrSubmitTx
     = ErrSubmitTxNetwork ErrPostTx
     | ErrSubmitTxNoSuchWallet ErrNoSuchWallet
     | ErrSubmitTxImpossible ErrNoSuchTransaction
     deriving (Show, Eq)
 
--- | Errors that can occur when submitting an externally-signed transaction
---   to the network.
-data ErrSubmitExternalTx
-    = ErrSubmitExternalTxNetwork ErrPostTx
-    | ErrSubmitExternalTxDecode ErrDecodeSignedTx
-    deriving (Show, Eq)
-
 -- | Errors that can occur when trying to change a wallet's passphrase.
 data ErrUpdatePassphrase
     = ErrUpdatePassphraseNoSuchWallet ErrNoSuchWallet
@@ -2702,15 +2672,10 @@ data ErrSelectAssets
     | ErrSelectAssetsSelectionError SelectionError
     deriving (Generic, Eq, Show)
 
-data ErrJoinStakePool
-    = ErrJoinStakePoolNoSuchWallet ErrNoSuchWallet
-    | ErrJoinStakePoolCannotJoin ErrCannotJoin
-    deriving (Generic, Eq, Show)
-
-data ErrQuitStakePool
-    = ErrQuitStakePoolNoSuchWallet ErrNoSuchWallet
-    | ErrQuitStakePoolCannotQuit ErrCannotQuit
-    deriving (Generic, Eq, Show)
+data ErrStakePoolDelegation
+    = ErrStakePoolDelegationNoSuchWallet ErrNoSuchWallet
+    | ErrStakePoolJoin ErrCannotJoin
+    | ErrStakePoolQuit ErrCannotQuit
 
 -- | Errors that can occur when fetching the reward balance of a wallet
 newtype ErrFetchRewards
@@ -2724,16 +2689,6 @@ data ErrCheckWalletIntegrity
 
 instance Exception ErrCheckWalletIntegrity
 
-data ErrCannotJoin
-    = ErrAlreadyDelegating PoolId
-    | ErrNoSuchPool PoolId
-    deriving (Generic, Eq, Show)
-
-data ErrCannotQuit
-    = ErrNotDelegatingOrAboutTo
-    | ErrNonNullRewards Coin
-    deriving (Generic, Eq, Show)
-
 -- | Can't perform given operation because the wallet died.
 newtype ErrWalletNotResponding
     = ErrWalletNotResponding WalletId
@@ -2976,7 +2931,7 @@ instance Buildable TxSubmitLog where
                 [ "Submitting transaction "+|tx ^. #txId|+" to local node"
                 , blockMapF
                     [ ("Tx" :: Text, build tx)
-                    , ("SealedTx", build (show sealed))
+                    , ("SealedTx", build sealed)
                     , ("TxMeta", build meta) ]
                 ]
             BracketFinish res ->