deal with withdrawals in decodeSharedTx

lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs

@@ -712,6 +712,8 @@ import qualified Network.Ntp as Ntp
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Network.Wai.Handler.WarpTLS as Warp
 
+import qualified Debug.Trace as TR
+
 -- | How the server should listen for incoming requests.
 data Listen
     = ListenOnPort Port
@@ -2895,8 +2897,8 @@ constructSharedTransaction
 
         withdrawal <- case body ^. #withdrawal of
             Just SelfWithdraw -> liftIO $
-                W.mkSelfWithdrawalShared @_ @_ @n
-                    netLayer txLayer era db wid
+                W.mkSelfWithdrawalShared @n
+                    netLayer (txWitnessTagFor @SharedKey) era db
             _ -> pure NoWithdrawal
 
         let delegationTemplateM = Shared.delegationTemplate $ getState cp
@@ -2907,13 +2909,7 @@ constructSharedTransaction
             forM delegationRequest $
                 WD.handleDelegationRequest
                     trWorker db epoch knownPools
-                    getPoolStatus NoWithdrawal
-
-        withdrawal <- case body ^. #withdrawal of
-            Just SelfWithdraw -> liftIO $
-                W.shelleyOnlyMkSelfWithdrawal @_ @_ @n
-                      netLayer (txWitnessTagFor @SharedKey) era db
-            _ -> pure NoWithdrawal
+                    getPoolStatus withdrawal
 
         let txCtx = defaultTransactionCtx
                 { txWithdrawal = withdrawal
@@ -2959,26 +2955,26 @@ constructSharedTransaction
                 let refunds = case optionalDelegationAction of
                         Just Quit -> [W.stakeKeyDeposit pp]
                         _ -> []
+                rewardAccountM <- handler $ W.readSharedRewardAccount @n db
                 delCerts <- case optionalDelegationAction of
                     Nothing -> pure Nothing
                     Just action -> do
-                        resM <- handler $ W.readSharedRewardAccount @n db
                         --at this moment we are sure reward account is present
                         --if not ErrConstructTxDelegationInvalid would be thrown already
-                        pure $ Just (action, snd $ fromJust resM)
+                        pure $ Just (action, snd $ fromJust rewardAccountM)
 
                 pure $ ApiConstructTransaction
                     { transaction = balancedTx
                     , coinSelection =
                         mkApiCoinSelection deposits refunds
-                        delCerts md (unsignedTx outs apiDecoded delCerts)
+                        delCerts md (unsignedTx outs apiDecoded rewardAccountM)
                     , fee = apiDecoded ^. #fee
                     }
   where
     ti :: TimeInterpreter (ExceptT PastHorizonException IO)
     ti = timeInterpreter (api ^. networkLayer)
 
-    unsignedTx initialOuts decodedTx rewardDel = UnsignedTx
+    unsignedTx initialOuts decodedTx rewardAccountM = TR.trace ("unsignedTx:"<> show rewardAccountM<>" decodedTx:"<>show decodedTx) $ UnsignedTx
         { unsignedCollateral =
             mapMaybe toUnsignedTxInp (decodedTx ^. #collateral)
         , unsignedInputs =
@@ -2989,12 +2985,13 @@ constructSharedTransaction
         , unsignedChange =
             drop (length initialOuts)
                 $ map toUnsignedTxChange (decodedTx ^. #outputs)
-        , unsignedWithdrawals = case rewardDel of
+        , unsignedWithdrawals = case rewardAccountM of
                 Nothing -> []
                 Just (_, path) ->
                     mapMaybe (toUsignedTxWdrl path) (decodedTx ^. #withdrawals)
         }
 
+
 decodeSharedTransaction
     :: forall n . HasSNetworkId n
     => ApiLayer (SharedState n SharedKey)
@@ -3004,7 +3001,7 @@ decodeSharedTransaction
 decodeSharedTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _) = do
     era <- liftIO $ NW.currentNodeEra nl
     (txinsOutsPaths, collateralInsOutsPaths, outsPath, pp, certs, txId, fee
-        , metadata, scriptValidity, interval, witsCount)
+        , metadata, scriptValidity, interval, witsCount, withdrawals, rewardAcctM)
         <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do
         (cp, _, _) <- handler $ W.readWallet wrk
         let witCountCtx = toWitnessCountCtx SharedWallet (getState cp)
@@ -3015,6 +3012,7 @@ decodeSharedTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _
                 , resolvedInputs
                 , resolvedCollateralInputs
                 , outputs
+                , withdrawals
                 , metadata
                 , scriptValidity
                 }) = decodedTx
@@ -3051,6 +3049,8 @@ decodeSharedTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _
             , scriptValidity
             , interval
             , witsCount
+            , withdrawals
+            , rewardAcctM
             )
     pure $ ApiDecodedTransaction
         { id = ApiT txId
@@ -3060,7 +3060,9 @@ decodeSharedTransaction ctx (ApiT wid) (ApiSerialisedTransaction (ApiT sealed) _
         , collateral = map toInp collateralInsOutsPaths
         -- TODO: [ADP-1670]
         , collateralOutputs = ApiAsArray Nothing
-        , withdrawals = []
+        , withdrawals = case rewardAcctM of
+                Nothing -> []
+                Just acct -> map (toWrdl acct) $ Map.assocs withdrawals
         -- TODO minting/burning multisig
         , mint = emptyApiAssetMntBurn
         , burn = emptyApiAssetMntBurn
@@ -3220,13 +3222,17 @@ decodeTransaction
   where
     tl = ctx ^. W.transactionLayer @(KeyOf s) @'CredFromKeyK
 
-    toWrdl acct (rewardKey, (Coin c)) =
-        if rewardKey == acct then
-            ApiWithdrawalGeneral (ApiRewardAccount rewardKey)
-                (Quantity $ fromIntegral c) Our
-        else
-            ApiWithdrawalGeneral (ApiRewardAccount rewardKey)
-                (Quantity $ fromIntegral c) External
+toWrdl
+    :: RewardAccount
+    -> (RewardAccount, Coin)
+    -> ApiWithdrawalGeneral n
+toWrdl acct (rewardKey, (Coin c)) =
+    if rewardKey == acct then
+        ApiWithdrawalGeneral (ApiRewardAccount rewardKey)
+            (Quantity $ fromIntegral c) Our
+    else
+        ApiWithdrawalGeneral (ApiRewardAccount rewardKey)
+            (Quantity $ fromIntegral c) External
 
 ourRewardAccountRegistration :: ApiAnyCertificate n -> Bool
 ourRewardAccountRegistration = \case

lib/wallet/src/Cardano/Wallet.hs

@@ -585,7 +585,9 @@ import Data.List
 import Data.List.NonEmpty
     ( NonEmpty (..) )
 import Data.Maybe
-    ( fromMaybe, isJust, mapMaybe, maybeToList )
+    ( fromJust, fromMaybe, isJust, isNothing, mapMaybe, maybeToList )
+import Data.Proxy
+    ( Proxy (..) )
 import Data.Quantity
     ( Quantity (..) )
 import Data.Set
@@ -1269,23 +1271,20 @@ shelleyOnlyMkSelfWithdrawal netLayer txWitnessTag db =
         $ ExceptionReadRewardAccount ErrReadRewardAccountNotAShelleyWallet
 
 mkSelfWithdrawalShared
-    :: forall ktype tx n block
+    :: forall n block
      . NetworkLayer IO block
-    -> TransactionLayer SharedKey ktype tx
+    -> TxWitnessTag
     -> AnyCardanoEra
     -> DBLayer IO (SharedState n SharedKey) SharedKey
-    -> WalletId
     -> IO Withdrawal
-mkSelfWithdrawalShared netLayer txLayer era db wallet = do
-    rewardAccountM <-
-        runExceptT (readSharedRewardAccount db wallet)
-            >>= either (throwIO . ExceptionReadRewardAccount) pure
+mkSelfWithdrawalShared netLayer txWitnessTag era db = do
+    rewardAccountM <- readSharedRewardAccount db
     when (isNothing rewardAccountM) $
         throwIO $ ExceptionReadRewardAccount ErrReadRewardAccountMissing
     let (rewardAccount, derivationPath) = fromJust rewardAccountM
     balance <- getCachedRewardAccountBalance netLayer rewardAccount
     pp <- currentProtocolParameters netLayer
-    return $ case checkRewardIsWorthTxCost txLayer pp era balance of
+    return $ case checkRewardIsWorthTxCost txWitnessTag pp era balance of
         Left ErrWithdrawalNotBeneficial -> NoWithdrawal
         Right () -> WithdrawalSelf rewardAccount derivationPath balance