Skip to content

Commit

Permalink
Merge #1879 #2227
Browse files Browse the repository at this point in the history 
1879: Add transaction expiry slot for pending transactions r=KtorZ a=rvl

### Issue Number

Relates to ADP-93 / #1838.

### Overview

- Adds expiry slot to pending transactions in order to implement transaction TTL.
- Expiry slot and time is reported in the transaction history.
- At the expiry slot, pending transactions are marked Expired.
- Default TTL of 7200 slots is still hard coded.


2227: Fix mainnet network parameters r=KtorZ a=rvl

### Issue Number

Relates to #2226.

### Overview

- Rearrange byron/shelley code a little.
- Updates hardcoded epoch length (slots not blocks) and active slot coefficient values for mainnet.
- Also updates slot length parameter.
- Also updates the _minFee a_ parameter - but I'm uncertain why the value was like that before.


Co-authored-by: Rodney Lorrimar <[email protected]>
  • Loading branch information
@iohk-bors @rvl
iohk-bors[bot] and rvl authored Oct 9, 2020
3 parents e53bce0 + 327e021 + e7626ab commit ce650ab
Show file tree
Hide file tree
Showing 43 changed files with 1,234 additions and 1,073 deletions.
25 changes: 19 additions & 6 deletions lib/core-integration/src/Test/Integration/Framework/DSL.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,10 @@ module Test.Integration.Framework.DSL
-- * Lens
, walletId

-- * Constants
, minUTxOValue
, defaultTxTTL

-- * Helpers
, (</>)
, (!!)
Expand Down Expand Up @@ -110,7 +114,6 @@ module Test.Integration.Framework.DSL
, rootPrvKeyFromMnemonics
, unsafeGetTransactionTime
, getTxId
, minUTxOValue

-- * Delegation helpers
, mkEpochInfo
Expand Down Expand Up @@ -160,6 +163,7 @@ import Cardano.Mnemonic
import Cardano.Wallet.Api.Types
( AddressAmount
, ApiAddress
, ApiBlockReference (..)
, ApiByronWallet
, ApiCoinSelection
, ApiEpochInfo (ApiEpochInfo)
Expand All @@ -180,7 +184,6 @@ import Cardano.Wallet.Api.Types
, Iso8601Time (..)
, WalletStyle (..)
, insertedAt
, time
)
import Cardano.Wallet.Primitive.AddressDerivation
( AccountingStyle (..)
Expand Down Expand Up @@ -215,6 +218,7 @@ import Cardano.Wallet.Primitive.Types
, HistogramBar (..)
, PoolId (..)
, SlotLength (..)
, SlotNo (..)
, SortOrder (..)
, TxIn (..)
, TxOut (..)
Expand Down Expand Up @@ -522,11 +526,20 @@ walletId =
_set (s, v) = set typed (ApiT $ WalletId (unsafeCreateDigest v)) s

--
-- Helpers
-- Constants
--

-- | Min UTxO parameter for the test cluster.
minUTxOValue :: Natural
minUTxOValue = 1_000_000

-- | Wallet server's chosen transaction TTL value (in slots) when none is given.
defaultTxTTL :: SlotNo
defaultTxTTL = 7200

--
-- Helpers
--
data MnemonicLength = M9 | M12 | M15 | M18 | M21 | M24 deriving (Show)

genMnemonics :: MnemonicLength -> IO [Text]
Expand Down Expand Up @@ -574,10 +587,10 @@ waitForNextEpoch
:: Context t
-> IO ()
waitForNextEpoch ctx = do
epoch <- getFromResponse (#nodeTip . #epochNumber) <$>
epoch <- getFromResponse (#nodeTip . #slotId . #epochNumber) <$>
request @ApiNetworkInformation ctx Link.getNetworkInfo Default Empty
eventually "waitForNextEpoch: goes to next epoch" $ do
epoch' <- getFromResponse (#nodeTip . #epochNumber) <$>
epoch' <- getFromResponse (#nodeTip . #slotId . #epochNumber) <$>
request @ApiNetworkInformation ctx Link.getNetworkInfo Default Empty
unless (getApiT epoch' > getApiT epoch) $ fail "not yet"

Expand Down Expand Up @@ -1788,7 +1801,7 @@ getSlotParams ctx = do
r1 <- request @ApiNetworkInformation ctx
Link.getNetworkInfo Default Empty
let ApiT currentEpoch =
view #epochNumber
view (#slotId . #epochNumber)
$ fromMaybe (error "getSlotParams: tip is Nothing")
$ getFromResponse #networkTip r1

Expand Down
22 changes: 10 additions & 12 deletions lib/core-integration/src/Test/Integration/Scenario/API/Network.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,6 @@ import Cardano.Wallet.Api.Types
, NtpSyncingStatus (..)
, WalletStyle (..)
, epochStartTime
, getApiT
, nextEpoch
)
import Cardano.Wallet.Primitive.SyncProgress
Expand All @@ -28,8 +27,6 @@ import Control.Monad.IO.Class
( liftIO )
import Data.Generics.Internal.VL.Lens
( view, (^.) )
import Data.Maybe
( fromJust )
import Data.Time.Clock
( getCurrentTime )
import Test.Hspec
Expand Down Expand Up @@ -70,9 +67,10 @@ spec = describe "COMMON_NETWORK" $ do
, expectField (#nodeTip . #absoluteSlotNumber . #getApiT) (`shouldNotBe` 0)
]

let Just currentEpochNum = getApiT . (view #epochNumber) <$> (i ^. #networkTip)
let nextEpochNum = view (#epochNumber . #getApiT)
$ fromJust $ getFromResponse #nextEpoch r
let Just currentEpochNum =
view (#slotId . #epochNumber . #getApiT) <$> (i ^. #networkTip)
let Just nextEpochNum =
view (#epochNumber . #getApiT) <$> getFromResponse #nextEpoch r
nextEpochNum `shouldBe` currentEpochNum + 1

it "NETWORK_BYRON - Byron wallet has the same tip as network/information" $
Expand All @@ -85,21 +83,21 @@ spec = describe "COMMON_NETWORK" $ do
expectField (#syncProgress . #getApiT) (`shouldBe` Ready) sync

let epochNum =
getFromResponse (#nodeTip . #epochNumber . #getApiT) sync
getFromResponse (#nodeTip . #slotId . #epochNumber . #getApiT) sync
let slotNum =
getFromResponse (#nodeTip . #slotNumber . #getApiT) sync
getFromResponse (#nodeTip . #slotId . #slotNumber . #getApiT) sync
let blockHeight =
getFromResponse (#nodeTip . #height) sync
getFromResponse (#nodeTip . #block . #height) sync
let absSlot =
getFromResponse (#nodeTip . #absoluteSlotNumber) sync

res <- request @ApiByronWallet ctx
(Link.getWallet @'Byron w) Default Empty
verify res
[ expectField (#state . #getApiT) (`shouldBe` Ready)
, expectField (#tip . #epochNumber . #getApiT) (`shouldBe` epochNum)
, expectField (#tip . #slotNumber . #getApiT) (`shouldBe` slotNum)
, expectField (#tip . #height) (`shouldBe` blockHeight)
, expectField (#tip . #slotId . #epochNumber . #getApiT) (`shouldBe` epochNum)
, expectField (#tip . #slotId . #slotNumber . #getApiT) (`shouldBe` slotNum)
, expectField (#tip . #block . #height) (`shouldBe` blockHeight)
, expectField (#tip . #absoluteSlotNumber) (`shouldBe` absSlot)
]

Expand Down
35 changes: 32 additions & 3 deletions lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,7 +34,6 @@ import Cardano.Wallet.Api.Types
, WalletStyle (..)
, insertedAt
, pendingSince
, time
)
import Cardano.Wallet.Primitive.AddressDerivation
( PaymentAddress )
Expand Down Expand Up @@ -94,6 +93,7 @@ import Test.Integration.Framework.DSL
, Headers (..)
, Payload (..)
, between
, defaultTxTTL
, emptyByronWalletWith
, emptyRandomWallet
, emptyWallet
Expand Down Expand Up @@ -593,6 +593,35 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
(#balance . #available)
(`shouldBe` Quantity (faucetAmt - feeEstMax - amt)) ra2

it "TRANS_CREATE_10 - Pending transaction expiry" $ \ctx -> do
(wa, wb) <- (,) <$> fixtureWallet ctx <*> fixtureWallet ctx
let amt = minUTxOValue :: Natural

payload <- mkTxPayload ctx wb amt fixturePassphrase

r <- request @(ApiTransaction n) ctx
(Link.createTransaction @'Shelley wa) Default payload

verify r
[ expectSuccess
, expectResponseCode HTTP.status202
, expectField (#direction . #getApiT) (`shouldBe` Outgoing)
, expectField (#status . #getApiT) (`shouldBe` Pending)
, expectField #expiresAt (`shouldSatisfy` isJust)
]

-- This stuff would be easier with Control.Lens...

-- Get insertion slot and out of response.
let (_, Right apiTx) = r
let Just sl = view (#absoluteSlotNumber . #getApiT) <$> apiTx ^. #pendingSince

-- The expected expiry slot (adds the hardcoded default ttl)
let ttl = sl + defaultTxTTL

(view #absoluteSlotNumber <$> (apiTx ^. #expiresAt))
`shouldBe` Just (ApiT ttl)

it "TRANSMETA_CREATE_01 - Transaction with metadata" $ \ctx -> do
(wa, wb) <- (,) <$> fixtureWallet ctx <*> emptyWallet ctx
let amt = (minUTxOValue :: Natural)
Expand Down Expand Up @@ -1520,7 +1549,7 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
, replicate 10 (2 * minUTxOValue)
]
txs <- listAllTransactions @n ctx w
let [Just t2, Just t1] = fmap (fmap time . insertedAt) txs
let [Just t2, Just t1] = fmap (fmap (view #time) . insertedAt) txs
let matrix :: [TestCase [ApiTransaction n]] =
[ TestCase -- 1
{ query = toQueryString
Expand Down Expand Up @@ -2538,7 +2567,7 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
:: [ApiTransaction n]
-> UTCTime
unsafeGetTransactionTime txs =
case fmap time . insertedAt <$> txs of
case fmap (view #time) . insertedAt <$> txs of
(Just t):_ -> t
_ -> error "Expected at least one transaction with a time."

Expand Down
12 changes: 6 additions & 6 deletions lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Wallets.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1249,17 +1249,17 @@ spec = describe "SHELLEY_WALLETS" $ do
expectField (#syncProgress . #getApiT) (`shouldBe` Ready) sync

let epochNum =
getFromResponse (#nodeTip . #epochNumber . #getApiT) sync
getFromResponse (#nodeTip . #slotId . #epochNumber . #getApiT) sync
let slotNum =
getFromResponse (#nodeTip . #slotNumber . #getApiT) sync
getFromResponse (#nodeTip . #slotId . #slotNumber . #getApiT) sync
let blockHeight =
getFromResponse (#nodeTip . #height) sync
getFromResponse (#nodeTip . #block . #height) sync

res <- request @ApiWallet ctx
(Link.getWallet @'Shelley w) Default Empty
verify res
[ expectField (#state . #getApiT) (`shouldBe` Ready)
, expectField (#tip . #epochNumber . #getApiT) (`shouldBe` epochNum)
, expectField (#tip . #slotNumber . #getApiT) (`shouldBe` slotNum)
, expectField (#tip . #height) (`shouldBe` blockHeight)
, expectField (#tip . #slotId . #epochNumber . #getApiT) (`shouldBe` epochNum)
, expectField (#tip . #slotId . #slotNumber . #getApiT) (`shouldBe` slotNum)
, expectField (#tip . #block . #height) (`shouldBe` blockHeight)
]
2 changes: 1 addition & 1 deletion lib/core-integration/src/Test/Integration/Scenario/CLI/Network.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -109,4 +109,4 @@ spec = describe "COMMON_CLI_NETWORK" $ do

currentEpochNo :: ApiNetworkInformation -> EpochNo
currentEpochNo netInfo =
(fromJust (netInfo ^. #networkTip)) ^. #epochNumber . #getApiT
(fromJust (netInfo ^. #networkTip)) ^. #slotId . #epochNumber . #getApiT
29 changes: 17 additions & 12 deletions lib/core/src/Cardano/Wallet.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -840,6 +840,7 @@ restoreBlocks ctx wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomicall
let k = gp ^. #getEpochStability
let localTip = currentTip $ NE.last cps

updatePendingTxForExpiry (PrimaryKey wid) (view #slotNo localTip)
putTxHistory (PrimaryKey wid) txs
forM_ slotPoolDelegations $ \delegation@(slotNo, cert) -> do
liftIO $ logDelegation delegation
Expand Down Expand Up @@ -1595,10 +1596,10 @@ signPayment ctx wid argGenChange mkRewardAccount pwd md cs = db & \DBLayer{..} -

let keyFrom = isOwned (getState cp) (xprv, pwdP)
let rewardAcnt = mkRewardAccount (xprv, pwdP)
(tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
mkStdTx tl rewardAcnt keyFrom (nodeTip ^. #slotNo) md cs'
(tx, sealedTx, txExp) <- withExceptT ErrSignPaymentMkTx $ ExceptT $
pure $ mkStdTx tl rewardAcnt keyFrom (nodeTip ^. #slotNo) md cs'

(time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) s' tx cs'
(time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) s' tx cs' txExp
return (tx, meta, time, sealedTx)
where
ti :: TimeInterpreter IO
Expand Down Expand Up @@ -1636,10 +1637,11 @@ signTx ctx wid pwd md (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do
let cs = mempty { inputs = inps, outputs = outs }
let keyFrom = isOwned (getState cp) (xprv, pwdP)
let rewardAcnt = getRawKey $ deriveRewardAccount @k pwdP xprv
(tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
mkStdTx tl (rewardAcnt, pwdP) keyFrom (nodeTip ^. #slotNo) md cs
(tx, sealedTx, txExp) <- withExceptT ErrSignPaymentMkTx $ ExceptT $
pure $ mkStdTx tl (rewardAcnt, pwdP) keyFrom (nodeTip ^. #slotNo) md cs

(time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) (getState cp) tx cs
(time, meta) <- liftIO $
mkTxMeta ti (currentTip cp) (getState cp) tx cs txExp
return (tx, meta, time, sealedTx)
where
ti :: TimeInterpreter IO
Expand Down Expand Up @@ -1729,7 +1731,7 @@ signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do

let rewardAcnt = getRawKey $ deriveRewardAccount @k pwdP xprv
let keyFrom = isOwned (getState cp) (xprv, pwdP)
(tx, sealedTx) <- withExceptT ErrSignDelegationMkTx $ ExceptT $ pure $
(tx, sealedTx, txExp) <- withExceptT ErrSignDelegationMkTx $ ExceptT $ pure $
case action of
RegisterKeyAndJoin poolId ->
mkDelegationJoinTx tl poolId
Expand All @@ -1753,7 +1755,7 @@ signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
coinSel'

(time, meta) <- liftIO $
mkTxMeta ti (currentTip cp) s' tx coinSel'
mkTxMeta ti (currentTip cp) s' tx coinSel' txExp
return (tx, meta, time, sealedTx)
where
ti :: TimeInterpreter IO
Expand All @@ -1762,8 +1764,8 @@ signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
tl = ctx ^. transactionLayer @t @k
nl = ctx ^. networkLayer @t

-- | Construct transaction metadata from a current block header and a list
-- of input and output.
-- | Construct transaction metadata for a pending transaction from the block
-- header of the current tip and a list of input and output.
--
-- FIXME: There's a logic duplication regarding the calculation of the transaction
-- amount between right here, and the Primitive.Model (see prefilterBlocks).
Expand All @@ -1774,8 +1776,9 @@ mkTxMeta
-> s
-> Tx
-> CoinSelection
-> SlotNo
-> m (UTCTime, TxMeta)
mkTxMeta interpretTime blockHeader wState tx cs =
mkTxMeta interpretTime blockHeader wState tx cs expiry =
let
amtOuts =
sum (mapMaybe ourCoins (outputs cs))
Expand All @@ -1794,6 +1797,7 @@ mkTxMeta interpretTime blockHeader wState tx cs =
, slotNo = blockHeader ^. #slotNo
, blockHeight = blockHeader ^. #blockHeight
, amount = Quantity $ distance amtInps amtOuts
, expiry = Just expiry
}
)
where
Expand Down Expand Up @@ -1848,7 +1852,8 @@ submitExternalTx ctx bytes = do
nw = ctx ^. networkLayer @t
tl = ctx ^. transactionLayer @t @k

-- | Forget pending transaction.
-- | Forget pending transaction. This happens at the request of the user and
-- will remove the transaction from the history.
forgetPendingTx
:: forall ctx s k.
( HasDBLayer s k ctx
Expand Down
Loading

0 comments on commit ce650ab

Please sign in to comment.