diff --git a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs index 6a3b42ed0d6..9be237dabac 100644 --- a/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs +++ b/lib/core-integration/src/Test/Integration/Scenario/API/Shelley/TransactionsNew.hs @@ -214,8 +214,6 @@ import qualified Data.Text.Encoding as T import qualified Network.HTTP.Types.Status as HTTP import qualified Test.Integration.Plutus as PlutusScenario -import qualified Debug.Trace as TR - spec :: forall n. ( DecodeAddress n @@ -2396,7 +2394,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do }|] rTx4 <- request @(ApiConstructTransaction n) ctx (Link.createUnsignedTransaction @'Shelley src) Default delegationQuit - TR.trace ("\n!!!!QUIT!!!\n") $ verify rTx4 + verify rTx4 [ expectResponseCode HTTP.status202 , expectField (#coinSelection . #depositsTaken) (`shouldBe` []) , expectField (#coinSelection . #depositsReturned) (`shouldBe` [depositAmt]) @@ -2425,7 +2423,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do let txid3 = getFromResponse (#id) submittedTx4 let queryTx3 = Link.getTransaction @'Shelley src (ApiTxId txid3) rGetTx3 <- request @(ApiTransaction n) ctx queryTx3 Default Empty - TR.trace ("\n!!!!Sumbited!!!!\n") $ verify rGetTx3 + verify rGetTx3 [ expectResponseCode HTTP.status200 , expectField #depositTaken (`shouldBe` Quantity 0) , expectField #depositReturned (`shouldBe` depositAmt) @@ -2439,7 +2437,7 @@ spec = describe "NEW_SHELLEY_TRANSACTIONS" $ do -- transaction history shows deposit returned rGetTx4 <- request @(ApiTransaction n) ctx queryTx3 Default Empty - TR.trace ("\n!!!!In ledger!!!!\n") $ verify rGetTx4 + verify rGetTx4 [ expectResponseCode HTTP.status200 , expectField #depositTaken (`shouldBe` Quantity 0) , expectField #depositReturned (`shouldBe` depositAmt) diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 717ed7136e1..e3a6be4f2ed 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/lib/core/src/Cardano/Wallet.hs @@ -540,6 +540,8 @@ import Safe ( lastMay ) import Statistics.Quantile ( medianUnbiased, quantiles ) +import Text.Pretty.Simple + ( pShow ) import Type.Reflection ( Typeable, typeRep ) import UnliftIO.Exception @@ -568,8 +570,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Vector as V -import Text.Pretty.Simple - ( pShow ) + -- $Development -- __Naming Conventions__ @@ -2142,9 +2143,13 @@ mkTxMetaWithoutSel blockHeader wState txCtx inps outs = w@WithdrawalSelf{} -> Coin.add (withdrawalToCoin w) WithdrawalExternal{} -> Prelude.id NoWithdrawal -> Prelude.id + dir = if (txCtx ^. #txDelegationAction) == Just Quit then + Incoming + else + Outgoing in return TxMeta { status = Pending - , direction = Outgoing + , direction = dir , slotNo = blockHeader ^. #slotNo , blockHeight = blockHeader ^. #blockHeight , amount = Coin.distance amtInps amtOuts @@ -3082,6 +3087,7 @@ data ErrSubmitTransaction = ErrSubmitTransactionNoSuchWallet ErrNoSuchWallet | ErrSubmitTransactionForeignWallet | ErrSubmitTransactionPartiallySignedOrNoSignedTx Int Int + | ErrSubmitTransactionMultidelegationNotSupported deriving (Show, Eq) -- | Errors that can occur when constructing an unsigned transaction. diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 468439d053b..8045fce81a9 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -632,8 +632,6 @@ import qualified Data.Text.Encoding as T 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 @@ -2425,6 +2423,17 @@ submitTransaction ctx apiw@(ApiT wid) apitx@(ApiSerialisedTransaction (ApiT seal let ourOuts = getOurOuts apiDecoded let ourInps = getOurInps apiDecoded + let ourDel = + filter isJust $ + map isJoiningOrQuitting $ apiDecoded ^. #certificates + when (length ourDel > 1) $ + liftHandler $ throwE ErrSubmitTransactionMultidelegationNotSupported + + let delAction = case ourDel of + [Just del] -> Just del + [] -> Nothing + _ -> error "impossible to be here due to check above" + let allInpsNum = length $ apiDecoded ^. #inputs let witsNum = length $ getSealedTxWitnesses sealedTx when (allInpsNum > witsNum) $ @@ -2437,10 +2446,16 @@ submitTransaction ctx apiw@(ApiT wid) apitx@(ApiSerialisedTransaction (ApiT seal let txCtx = defaultTransactionCtx { txTimeToLive = ttl , txWithdrawal = wdrl + , txDelegationAction = delAction } txMeta <- liftHandler $ W.constructTxMeta @_ @s @k wrk wid txCtx ourInps ourOuts + let txMeta' = + if (txCtx ^. #txDelegationAction) == Just Quit then + txMeta & #direction .~ W.Incoming + else + txMeta liftHandler - $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx) + $ W.submitTx @_ @s @k wrk wid (tx, txMeta', sealedTx) return $ ApiTxId (apiDecoded ^. #id) where (tx,_,_,_) = decodeTx tl sealedTx @@ -2487,6 +2502,15 @@ submitTransaction ctx apiw@(ApiT wid) apitx@(ApiSerialisedTransaction (ApiT seal all isInpForeign generalInps && all isWdrlForeign generalWdrls + isJoiningOrQuitting = \case + WalletDelegationCertificate (JoinPool _ (ApiT poolId)) -> + Just $ Join poolId + WalletDelegationCertificate (QuitPool _) -> + Just Quit + _ -> + Nothing + + joinStakePool :: forall ctx s n k. ( ctx ~ ApiLayer s k @@ -3365,7 +3389,7 @@ mkApiTransaction timeInterpreter setTimeReference tx = do (natural (tx ^. (#txMeta . #blockHeight))) expRef <- traverse makeApiSlotReference' (tx ^. (#txMeta . #expiry)) - TR.trace ("tx:"<> show tx) $ return $ apiTx & setTimeReference .~ Just timeRef & #expiresAt .~ expRef + return $ apiTx & setTimeReference .~ Just timeRef & #expiresAt .~ expRef where -- Since tx expiry can be far in the future, we use unsafeExtendSafeZone for -- now. @@ -4029,6 +4053,12 @@ instance IsServerError ErrSubmitTransaction where , " inputs and ", toText foundWitsNo, " witnesses included." , " Submit fully-signed transaction." ] + ErrSubmitTransactionMultidelegationNotSupported -> + apiError err403 CreatedMultidelegationTransaction $ mconcat + [ "It looks like the transaction to be sent contains" + , "multiple delegations, which is not supported at this moment." + , "Please use at most one delegation action in a submitted transaction: join, quit or none." + ] instance IsServerError ErrSubmitTx where toServerError = \case