diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,62 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html) +## [1.13.0] - 2026-11-13 + +Transactions are handed over at once, a payment that a block replaced is +answered 410, and what a reorganisation puts back stays in the mempool. + +### Added +- **A transaction that a block replaced is answered 410, Gone**, at + `/transaction/:txid` and its raw form, with the transaction of the block + that won (`replaced-by`) and its height, for 2016 blocks. It was 404, as + for a transaction that never was, and a payment that a reorganisation + replaced simply vanished. A store keeps it with the block and deletes it + with its revert. The stores of a fleet keep it in the shared pool, as + the fleet tip moves past the block, and answer from that alike: a + store's own record depends on its own mempool. A transaction replaced in + the mempool is still 404. The client of haskoin-store-data reports the + 410 as an error it does not know, until that package learns it. + +### Changed +- **`POST /transactions` answers 202, "handed over", at once.** The store + checks the transaction, hands it to every peer, each on a connection of + its own, and answers as soon as they took it, with the id and a message. + It no longer waits up to `--publish-timeout` for a node to announce the + transaction back: the wait was arbitrary, and said less than it seemed, + as Bitcoin Core refuses in silence. The transaction shows in the store + when a node announces it, usually within a second. A transaction that the + store has in a block is still answered 200, and one that a node refuses + over RPC, or that every peer refuses with a reason, 400. The client of + haskoin-store-data takes the new answer as it took the old one. +- With `--node-rpc`, a transaction that the node takes is answered 202 too. +- In the library, `Haskoin.Store.Web.Publish` answers with what was done + (`Answer`: `ToPeers`, `ToNode`, `InBlock` and refusals) in place of + `Verdict`, and has no `Limits` or `Outbox`. `Haskoin.Store.Logic.Layered`'s + `revertBlock` takes the time of the revert, and `Haskoin.Store.Logic` has + `revertBlockAt`, which the tests compare it with. + +### Removed +- **`--publish-timeout`** (`PUBLISH_TIMEOUT`), and the outbox that kept + failed transactions from being sent again for ten minutes. + +### Fixed +- **Transactions that cost the store its connections are refused.** On + regtest, a signature pushed in a longer form than it needs, and more + CashTokens out than in, both passed the store's checks, and Bitcoin Cash + Node closed every connection of the store when it was sent one. The + store now refuses an input script that does more than push data or + pushes it in a longer form than it needs, tokens that break the rules of + CashTokens, and a version that nodes do not take: 1 and 2 on Bitcoin + Cash, 1 to 3 on Bitcoin. `docs/publishing.md` has what was measured. +- **A transaction that a reorganisation puts back in the mempool stays + there.** It went back with the time of its block, and the store deletes + mempool transactions older than `--mempool-timeout` (14 days) on every + clock tick: a transaction of a block older than that was gone in under a + second, while the nodes kept it. On a regtest chain whose blocks are + older than the timeout, every reorganisation did it. It now goes back + with the time of the revert. + ## [1.12.1] - 2026-11-13 ### Fixed diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -227,15 +227,14 @@ curl -X POST --data-binary @tx.hex localhost:3000/transactions ``` -The body is the signed transaction in hex. The store hands it to one full -node and answers with the transaction id once a node has announced it back -and the store has it: the wallet's history shows it on the next request. +The body is the signed transaction in hex. The store checks it, hands it to +its peers and answers 202 with the transaction id at once. When a node +announces it, usually within a second, the wallet's history shows it. A transaction that cannot be valid, or that a node refuses with a reason, is -answered 400 with the reason. A 500 means that the store could not find out: -post the same transaction again, which is safe. A transaction that the store -lists as unconfirmed is given to a node again when it is posted, in case the -network forgot it. +answered 400 with the reason. Posting the same transaction again is safe: it +is handed over again, which gets a payment that the network forgot back to +it. [Publishing](#publishing) has the rest. ### 6. Stay up to date without polling @@ -345,8 +344,7 @@ | `--max-full-item-count` | `MAX_FULL_ITEM_COUNT` | `5000` | Most full transactions in a list (0 = no limit) | | `--max-offset` | `MAX_OFFSET` | `50000` | Largest `offset` (0 = no limit) | | `--slow-request` | `SLOW_REQUEST` | `5` | Seconds a request may take before the log warns of it (0 = never) | -| `--publish-timeout` | `PUBLISH_TIMEOUT` | `30` | Seconds that `POST /transactions` waits for a node to announce the transaction back | -| `--node-rpc` | `NODE_RPC` | none | JSON-RPC URL of a full node, such as `http://user:password@127.0.0.1:8332/`, to publish transactions through; without it, or when it does not answer, they go to a peer | +| `--node-rpc` | `NODE_RPC` | none | JSON-RPC URL of a full node, such as `http://user:password@127.0.0.1:8332/`, to publish transactions through; without it, or when it does not answer, they go to the peers | | `--def-item-count` | `DEF_ITEM_COUNT` | `100` | Items in a list when no `limit` is given | | `--xpub-gap` | `XPUB_GAP` | `32` | Unused addresses kept after the last used one of each chain of an xpub; payments further away are not seen | | `--xpub-gap-init` | `XPUB_GAP_INIT` | `20` | Addresses looked at for an xpub with no transactions; an xpub with none used among them counts as unused | @@ -578,41 +576,37 @@ The store does not check scripts, so a transaction that a client posts never goes into its mempool directly: anyone could show a payment that will -never confirm. It is handed to one full node, and comes in when a node -announces it back. +never confirm. It is handed over, and comes in when a node announces it. -- **A connection of its own.** The transaction goes to a node on a - connection made for it, not on those the store syncs from. A node does - not announce a transaction to the connection that gave it. On the others - the store hears of it as of any transaction, and imports it the same way. -- **The answer waits for that**, up to `--publish-timeout` seconds. A 200 - means that a full node accepted the transaction and the store has it. -- **The store checks what it can first**: that the inputs exist and are - not spent, that a coinbase is old enough, the amounts, the lock time, - the size and the dust rule of relay, and the signature of every coin - that is locked to one key, on both networks. A transaction that fails - is refused with the reason, and nothing is sent. A script of any other - kind is left to the node. +- **Checked first**: that the inputs exist and are not spent, that a + coinbase is old enough, the amounts, the lock time, the version, that + the input scripts only push data in its shortest form, the tokens of + Bitcoin Cash, the size and the dust rule of relay, and the signature of + every coin that is locked to one key. A transaction that fails is + refused with the reason, and nothing is sent. +- **Handed to every peer, each on a connection of its own**, and answered + 202 as soon as they took it. The store does not wait to see what the + network makes of it. A node does not announce a transaction to the + connection that gave it; on those the store syncs from it hears of it as + of any transaction, and imports it the same way. - **Over the RPC of a node, when the store has it.** With `--node-rpc` - the store gives the transaction to a full node over its RPC. The node - checks everything and says why it refuses. If the node does not - answer, the transaction goes to a peer instead. + the store gives the transaction to a full node over its RPC instead. The + node checks everything and says why it refuses. If the node does not + answer, the transaction goes to the peers. - **To a peer, only what the store verified.** A peer that is sent a - transaction it finds invalid may close every connection of the store. - So a transaction with an input that the store cannot verify, a script - that is not a key or a multisig, is refused unless there is an RPC to - send it over. Give the store the RPC of a node to publish those. -- **The same transaction is sent once**, however often it is posted. + transaction it finds invalid may close every connection of the store, + and Bitcoin Cash Node does. So a transaction with an input that the store + cannot verify, a script that is not a key or a multisig, is refused + unless there is an RPC to send it over; and so are the transactions that + were measured to cost the store its connections. - **Whitelist the store on your nodes** (`-whitelist` in Bitcoin Core and Bitcoin Cash Node). A node announces to a whitelisted peer without - delay, so the answer takes milliseconds; otherwise Bitcoin Core takes - five seconds on average. And a node that finds a transaction invalid may - close every connection of the peer that sent it, which it never does to - a whitelisted one. The store then connects again, does not send that - transaction a second time, and goes on publishing the others. + delay, so the transaction shows in the store at once; otherwise Bitcoin + Core takes five seconds on average. And a node never closes the + connections of a whitelisted peer. `docs/publishing.md` has the design, what was measured on Bitcoin Core and -Bitcoin Cash Node, and how it differs from versions before 1.11.0. +Bitcoin Cash Node, and how it differs from earlier versions. ### The database @@ -627,7 +621,8 @@ changes the chain's data. - **A transaction that leaves the mempool unconfirmed is forgotten**: it was replaced, double-spent by a block, or too old. The API answers 404 for - it. + it, or 410, with the transaction that won, for one that a block replaced + in the last 2016 blocks. - **Each request reads one snapshot** of the database, so everything in an answer is of the same moment. @@ -743,7 +738,7 @@ | `Haskoin.Store.Fleet.Member`, `Haskoin.Store.Fleet.XPub` | A fleet, and its cache | | `Haskoin.Store.Web`, `Haskoin.Store.Web.Events` | The web server, and `/events` | | `Haskoin.Store.Web.Pieces` | Answers that are sent while they are read | -| `Haskoin.Store.Web.Publish` | Publishing a transaction through a full node | +| `Haskoin.Store.Web.Publish` | Checking a transaction and handing it to the peers, or to a full node over RPC | The rules and queries of version 20 (`Haskoin.Store.Logic`, `Haskoin.Store.Database.Query`) stay in the library as a reference. The diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -272,8 +272,6 @@ env "TX_TIMEOUT" d.txTimeout readMaybe slowRequest <- env "SLOW_REQUEST" d.slowRequest readMaybe - publishTimeout <- - env "PUBLISH_TIMEOUT" d.publishTimeout readMaybe return WebLimits {..} -- | Names of the supported networks, separated by pipes. @@ -442,13 +440,6 @@ <> helpEnv "SLOW_REQUEST" "Warn in the log of requests that take this long (0 = never)" <> showDefault <> value c.webLimits.slowRequest - publishTimeout <- - option auto $ - metavar "SECONDS" - <> long "publish-timeout" - <> helpEnv "PUBLISH_TIMEOUT" "Wait this long for a published transaction to come back from a node" - <> showDefault - <> value c.webLimits.publishTimeout return WebLimits {..} redis <- flag c.redis True $ @@ -615,7 +606,9 @@ strOption $ metavar "URL" <> long "node-rpc" - <> helpEnv "NODE_RPC" "Publish transactions over the JSON-RPC of this full node, and through a peer when it fails" + <> helpEnv + "NODE_RPC" + "Publish transactions over the JSON-RPC of this full node, and through the peers when it fails" <> value c.nodeRpc tlsCert <- strOption $ diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store -version: 1.12.1 +version: 1.13.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: An indexer for Bitcoin and Bitcoin Cash. It downloads blocks and mempool transactions from the peer-to-peer network, indexes them in RocksDB, and diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -895,7 +895,8 @@ logWarn self $ "Reverting best block: " <> blockHashToHex h - runImport self net ctx (`revertBlock` h) >>= \case + now <- floor . utcTimeToPOSIXSeconds <$> getCurrentTime + runImport self net ctx (\wr -> revertBlock wr now h) >>= \case Left e -> do logError self $ "Could not revert block " diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -31,6 +31,8 @@ Start (..), StoreRead (..), StoreEvent (..), + Replaced (..), + replacedKept, getActiveBlock, getActiveTxData, notDeleted, @@ -84,7 +86,8 @@ import Data.Map.Strict qualified as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Ord (Down (..)) -import Data.Serialize (encode) +import Data.Serialize (Serialize (..), encode) +import GHC.Generics (Generic) import Data.Time.Clock.System ( getSystemTime, systemNanoseconds, @@ -228,8 +231,47 @@ xPubTxCount :: XPubSpec -> [XPubBal] -> IO Word32, -- | number of distinct transactions of a set of addresses, counted -- without reading them - getAddressesTxCount :: [Address] -> IO Word32 + getAddressesTxCount :: [Address] -> IO Word32, + -- | what is kept of a transaction that a block of the main chain + -- replaced, if it did in the last 'replacedKept' blocks + getReplaced :: TxHash -> IO (Maybe Replaced) } + +-- | What the store keeps of a mempool transaction that a block replaced: +-- the block confirmed a transaction that spends an output that it spent, +-- or that one of its unconfirmed ancestors spent. +-- +-- The store keeps nothing else of a transaction that leaves the mempool +-- unconfirmed, and a wallet that asked for it got a 404, as for a +-- transaction that never was: it could not tell a payment that lost to +-- another from one that it mistyped. With this it is told which +-- transaction won, and in which block. +-- +-- A store keeps it with the chain: written when the block is imported and +-- deleted when it is reverted, for 'replacedKept' blocks. That depends on +-- the mempool that the block found as well, which is each store's own, so +-- the stores of a fleet answer from what the shared pool keeps instead +-- ("Haskoin.Store.Fleet.Pool".'Haskoin.Store.Fleet.Pool.advanceReplacing'), +-- which is the same for all of them. +data Replaced = Replaced + { -- | the transaction of the block that spends what it, or an ancestor, + -- spent + by :: !TxHash, + -- | the height of the block + height :: !BlockHeight + } + deriving (Eq, Show, Generic) + +instance Serialize Replaced where + put r = put r.by >> put r.height + get = Replaced <$> get <*> get + +-- | Blocks for which a 'Replaced' is kept: 2016, two weeks of blocks of ten +-- minutes, as long as a mempool keeps a transaction by default +-- (@--mempool-timeout@). A wallet that has not looked for two weeks finds +-- the transaction unknown. +replacedKept :: BlockHeight +replacedKept = 2016 -- | Data of a block, or 'Nothing' if it is unknown or not in the main chain. getActiveBlock :: StoreRead -> BlockHash -> IO (Maybe BlockData) diff --git a/src/Haskoin/Store/Database/Query.hs b/src/Haskoin/Store/Database/Query.hs --- a/src/Haskoin/Store/Database/Query.hs +++ b/src/Haskoin/Store/Database/Query.hs @@ -35,6 +35,8 @@ getBestBlock, getBlocksAtHeight, getBlock, + getReplaced, + getReplacedAt, -- * Transactions getTxData, @@ -140,6 +142,7 @@ ) import Haskoin.Store.Common ( Limits (..), + Replaced, Start (..), StoreRead (..), applyLimitsC, @@ -196,7 +199,8 @@ xPubUnspents = \_ -> xPubUnspents r, xPubTxs = \_ -> xPubTxs r, xPubTxCount = \_ -> xPubTxCount r, - getAddressesTxCount = getAddressesTxCount r + getAddressesTxCount = getAddressesTxCount r, + getReplaced = getReplaced r } -- | Count something in the metrics, if they are enabled. @@ -221,6 +225,16 @@ Just ls -> do count r $ \s -> incrementCounter s.dataBlockCount (length ls) return ls + +-- | What is kept of a transaction that a block replaced ('Replaced'). +getReplaced :: DatabaseReader -> TxHash -> IO (Maybe Replaced) +getReplaced r h = retrieveCF r.db (blockCF r.db) (ReplacedKey h) + +-- | The transactions that the block at a height replaced. +getReplacedAt :: DatabaseReader -> BlockHeight -> IO [TxHash] +getReplacedAt r h = do + rows <- matchingAsListCF r.db (heightCF r.db) (ReplacedAtKeyH h) + return [t | (ReplacedAtKey _ t, ()) <- rows] -- | Data of a block. getBlock :: DatabaseReader -> BlockHash -> IO (Maybe BlockData) diff --git a/src/Haskoin/Store/Database/Query/Layered.hs b/src/Haskoin/Store/Database/Query/Layered.hs --- a/src/Haskoin/Store/Database/Query/Layered.hs +++ b/src/Haskoin/Store/Database/Query/Layered.hs @@ -260,7 +260,8 @@ xPubUnspents = \_ -> xPubUnspents v, xPubTxs = \_ -> xPubTxs v, xPubTxCount = \_ -> xPubTxCount v, - getAddressesTxCount = getAddressesTxCount v + getAddressesTxCount = getAddressesTxCount v, + getReplaced = Q.getReplaced r } -- | The queries of a database as a t'StoreRead', each on a view of its @@ -295,7 +296,8 @@ xPubUnspents = \x bs l -> one (\q -> q.xPubUnspents x bs l), xPubTxs = \x bs l -> one (\q -> q.xPubTxs x bs l), xPubTxCount = \x bs -> one (\q -> q.xPubTxCount x bs), - getAddressesTxCount = \as -> one (\q -> q.getAddressesTxCount as) + getAddressesTxCount = \as -> one (\q -> q.getAddressesTxCount as), + getReplaced = \h -> one (\q -> q.getReplaced h) } where one :: (StoreRead -> IO a) -> IO a diff --git a/src/Haskoin/Store/Database/Query/Pooled.hs b/src/Haskoin/Store/Database/Query/Pooled.hs --- a/src/Haskoin/Store/Database/Query/Pooled.hs +++ b/src/Haskoin/Store/Database/Query/Pooled.hs @@ -84,6 +84,7 @@ ) import Haskoin.Store.Common ( Limits (..), + Replaced, Start (..), StoreRead (..), applyLimitsC, @@ -160,7 +161,10 @@ page :: Word32 -> Word32 -> IO [(UnixTime, TxHash)], -- | the transactions of the pool whose hash starts with six bytes, as -- 'decodeTxKey' gives them - startingWith :: (Word32, Word16) -> IO [TxHash] + startingWith :: (Word32, Word16) -> IO [TxHash], + -- | what the pool keeps of a transaction that a block replaced as the + -- tip moved past it ('Haskoin.Store.Fleet.Pool.advanceReplacing') + replaced :: TxHash -> IO (Maybe Replaced) } -- | The queries of a store that answers from the chain as a reader has it, @@ -194,7 +198,11 @@ xPubUnspents = \_ -> xPubUnspents r pool, xPubTxs = \_ xbals -> getAddressesTxs r pool (Q.usedAddresses xbals), xPubTxCount = \_ xbals -> getAddressesTxCount r pool (Q.usedAddresses xbals), - getAddressesTxCount = getAddressesTxCount r pool + getAddressesTxCount = getAddressesTxCount r pool, + -- from the pool, which keeps what the blocks replaced as the tip + -- moves past them, the same for every store: not from the store's + -- own database, which has what its own mempool lost + getReplaced = pool.replaced } where only = \case @@ -511,7 +519,9 @@ page = \offset limit -> Q.getMempoolPage r Limits {limit = limit, offset = offset, start = Nothing}, startingWith = \prefix -> do rows <- matchingAsListCF r.db (mempoolCF r.db) (TxKeyS prefix) - return [h | (TxKey h, _ :: TxData) <- rows] + return [h | (TxKey h, _ :: TxData) <- rows], + -- what the blocks replaced, as the store's own database keeps it + replaced = Q.getReplaced r } where entries :: Address -> IO [(MemAddrKey, MemAddrVal)] diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -88,6 +88,8 @@ MemSummary (..), MemDeletedKey (..), MigrationKey (..), + ReplacedKey (..), + ReplacedAtKey (..), SpenderKey (..), SpenderVal (..), spenderGroup, @@ -127,6 +129,7 @@ getWord32be, getWord64be, getWord8, + putWord32be, putWord64be, putWord8, runGet, @@ -146,6 +149,7 @@ scriptToAddressBS, ) import Haskoin.Crypto +import Haskoin.Store.Common (Replaced) import Haskoin.Store.Data ( Balance (..), BlockData, @@ -641,6 +645,49 @@ instance Key MigrationKey instance KeyValue MigrationKey Word32 + +-- | Key of what is kept of a mempool transaction that a block replaced +-- ('Replaced'), in the @block@ column family, since haskoin-store 1.13.0. +-- It is part of the chain: written and deleted only by the import and the +-- revert of blocks. +data ReplacedKey = ReplacedKey !TxHash + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize ReplacedKey where + -- 0x11 · TxHash + put (ReplacedKey h) = putWord8 0x11 >> put h + get = do + guard . (== 0x11) =<< getWord8 + ReplacedKey <$> get + +instance Key ReplacedKey + +instance KeyValue ReplacedKey Replaced + +-- | The transactions replaced by the block at a height, in the @height@ +-- column family, which the revert of the block forgets, and which are +-- forgotten 'Haskoin.Store.Common.replacedKept' blocks later. The height comes first, written +-- big-endian, so that a scan of one height finds them all. The column +-- family has no prefix extractor, which a scan by five bytes needs. +data ReplacedAtKey + = -- | a transaction replaced at a height + ReplacedAtKey !BlockHeight !TxHash + | -- | short key that matches the transactions replaced at a height + ReplacedAtKeyH !BlockHeight + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize ReplacedAtKey where + -- 0x12 · height · TxHash + put (ReplacedAtKey h t) = put (ReplacedAtKeyH h) >> put t + -- 0x12 · height + put (ReplacedAtKeyH h) = putWord8 0x12 >> putWord32be h + get = do + guard . (== 0x12) =<< getWord8 + ReplacedAtKey <$> getWord32be <*> get + +instance Key ReplacedAtKey + +instance KeyValue ReplacedAtKey () -- | Key of the inputs of blocks that spend some outputs of a transaction, -- in the @spender@ column family, since database version 22: the diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -91,6 +91,11 @@ insertMempoolAddr, deleteMempoolAddr, getMempoolAddr, + + -- * Transactions that blocks replaced + insertReplaced, + deleteReplaced, + getReplacedAt, ) where @@ -125,6 +130,7 @@ txHash, ) import Haskoin.Node (Logger) +import Haskoin.Store.Common (Replaced (..)) import Haskoin.Store.Data import Haskoin.Store.Database.Mempool qualified as M import Haskoin.Store.Database.Query qualified as Q @@ -197,6 +203,10 @@ -- | Changed entries of the mempool by address: 'Nothing' for a deletion. type MemAddrTable = H.BasicHashTable MemAddrKey (Maybe MemAddrVal) +-- | Changed records of transactions that blocks replaced: 'Nothing' for a +-- deletion. +type ReplacedTable = H.BasicHashTable TxHash (Maybe Replaced) + -- | Changes made in a batch, not yet written to the database. data Memory = Memory { -- | network constants @@ -230,7 +240,9 @@ -- | inputs of blocks that spend outputs, by group of outputs -- as t'SpenderKey' says, each group as the batch leaves it: empty for one -- that has no spent output left - spenderTable :: !SpenderTable + spenderTable :: !SpenderTable, + -- | what is kept of transactions that blocks replaced + replacedTable :: !ReplacedTable } -- | Set the best block. @@ -388,7 +400,8 @@ memTxOps db memTxTable, memSpenderOps db memSpenderTable, memAddrOps db memAddrTable, - spenderOps db spenderTable + spenderOps db spenderTable, + replacedOps db replacedTable ] -- | Operation for the change of the best block, if any. @@ -406,6 +419,23 @@ f k (Just d) = insertOpCF (blockCF db) (BlockKey k) d f k Nothing = deleteOpCF (blockCF db) (BlockKey k) +-- | Operations for changed records of replaced transactions: the record, +-- and its entry at the height of its block. A record that is deleted, or +-- kept again at another height, takes its old entry with it. +replacedOps :: DB -> ReplacedTable -> IO [BatchOp] +replacedOps db t = concat <$> (H.toList t >>= mapM f) + where + f (h, new) = do + old <- retrieveCF db (blockCF db) (ReplacedKey h) :: IO (Maybe Replaced) + let forget = + [ deleteOpCF (heightCF db) (ReplacedAtKey o.height h) + | Just o <- [old], + fmap (.height) new /= Just o.height + ] + return . (forget <>) $ case new of + Just r -> [insertOpCF (blockCF db) (ReplacedKey h) r, insertOpCF (heightCF db) (ReplacedAtKey r.height h) ()] + Nothing -> [deleteOpCF (blockCF db) (ReplacedKey h)] + -- | Operations for changed block heights. blockHeightOps :: DB -> HeightTable -> IO [BatchOp] blockHeightOps db t = map (uncurry f) <$> (H.toList t) @@ -627,6 +657,25 @@ kept = IntMap.filterWithKey (\i _ -> (fromIntegral i `div` spenderGroup) `notElem` replaced) stored return (IntMap.unions (kept : map snd changed)) +-- | Keep what a block replaced. +insertReplaced :: Writer -> TxHash -> Replaced -> IO () +insertReplaced w h r = H.insert w.memory.replacedTable h (Just r) + +-- | Forget what was kept of a replaced transaction. +deleteReplaced :: Writer -> TxHash -> IO () +deleteReplaced w h = H.insert w.memory.replacedTable h Nothing + +-- | The transactions that the block at a height replaced, with the changes +-- of the batch applied. +getReplacedAt :: Writer -> BlockHeight -> IO [TxHash] +getReplacedAt w height = do + stored <- Q.getReplacedAt w.reader height + changes <- H.toList w.memory.replacedTable + let changed = HashMap.fromList changes + kept = filter (not . (`HashMap.member` changed)) stored + added = [h | (h, Just r) <- changes, r.height == height] + return (kept <> added) + -- | The mempool in the database with the changes of this batch applied, -- newest first. getMempool :: Writer -> IO [(UnixTime, TxHash)] @@ -657,6 +706,7 @@ memSpenderTable <- liftIO H.new memAddrTable <- liftIO H.new spenderTable <- liftIO H.new + replacedTable <- liftIO H.new return Memory {..} -- | Read the best block from the changes of the batch: 'Nothing' if unchanged, @Just Nothing@ if deleted. diff --git a/src/Haskoin/Store/Fleet/Member.hs b/src/Haskoin/Store/Fleet/Member.hs --- a/src/Haskoin/Store/Fleet/Member.hs +++ b/src/Haskoin/Store/Fleet/Member.hs @@ -112,7 +112,7 @@ import Data.List (nub, sortOn) import Data.Map.Strict qualified as Map import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe) -import Data.Serialize (Serialize, decode, encode) +import Data.Serialize (Serialize, decode, encode, get, getWord32be, putWord32be, runGet, runPut) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8) @@ -134,7 +134,7 @@ txHash, ) import Haskoin.Node (LogLevel (..)) -import Haskoin.Store.Common (Limits (..), StoreRead (..)) +import Haskoin.Store.Common (Limits (..), Replaced (..), StoreRead (..)) import Haskoin.Store.Data ( Balance (..), BlockData (..), @@ -642,12 +642,27 @@ Right added -> do old <- concat <$> mapM (bodies view) (reverse abandoned) new <- concat <$> mapM (confirmedBy r) (reverse added) + -- those of the abandoned blocks that this store has as + -- replaced: every store had them confirmed, and says the same + let named h rep = encode h <> encode rep.by <> runPut (putWord32be rep.height) + lostOnes <- fmap catMaybes . forM [h | (h, Nothing) <- old] $ \h -> + fmap (named h) <$> Q.getReplaced r h let pool = PoolChange { returned = [poolTx r.net r.ctx td | (_, Just td) <- old, not (coinbase td)], gone = [encode h | (h, found) <- old, maybe True coinbase found], confirmed = map (encode . txHash . (.tx)) new, - spent = [encode i.outpoint | td <- new, i <- td.tx.inputs, i.outpoint /= nullOutPoint] + -- with what spends each output and where, for what + -- the blocks replaced + spent = + [ encode i.outpoint <> encode (txHash td.tx) <> runPut (putWord32be h) + | td <- new, + BlockRef {height = h} <- [td.block], + i <- td.tx.inputs, + i.outpoint /= nullOutPoint + ], + height = Just bd.height, + lost = lostOnes } let path = map (headerHash . (.header)) (reverse added) return (Way Between {pool, added = new, reorganised = not (null abandoned), path}) @@ -1121,7 +1136,11 @@ page = \offset limit -> do rows <- ask "page" [num offset, num limit] return [(number time, h) | [member, time] <- groups 2 rows, Right h <- [decode member]], - startingWith = \start -> rights . map decode <$> ask "ids" [B.drop 1 (encode (TxKeyS start))] + startingWith = \start -> rights . map decode <$> ask "ids" [B.drop 1 (encode (TxKeyS start))], + replaced = \h -> + ask "replaced" [encode h] >>= \case + [value] | Right (by, height) <- runGet ((,) <$> get <*> getWord32be) value -> return (Just Replaced {..}) + _ -> return Nothing } where ask what args = poolRead conn keys 32 (Just tip) what args >>= maybe (throwIO TipMoved) (<$ checked) diff --git a/src/Haskoin/Store/Fleet/Pool.hs b/src/Haskoin/Store/Fleet/Pool.hs --- a/src/Haskoin/Store/Fleet/Pool.hs +++ b/src/Haskoin/Store/Fleet/Pool.hs @@ -73,6 +73,7 @@ -- * Following the tip Change (..), advance, + advanceReplacing, -- * What the pool holds for each address Entry (..), @@ -213,7 +214,40 @@ -- of the chain; and what spends an output that they spend leaves with -- everything that spends it. advance :: (Ord t, Ord o) => (o -> t) -> Change t o -> Pool t o -> Pool t o -advance maker change pool0 = clashed +advance maker change pool = let (p, _, _) = advanceReplacing maker change (const Nothing) [] Map.empty pool in p + +-- | 'advance', and what the new blocks replaced. Given a label for each +-- output that they spend, transactions of the abandoned blocks that the +-- store has as replaced, each with the transaction that replaced it and a +-- label, and those of earlier moves that still wait for theirs. Gives the +-- pool, what was replaced, each with its label, and what still waits. +-- +-- * A transaction of the pool that leaves because it, or an unconfirmed +-- ancestor of it, spent an output that the new blocks spend, was +-- replaced, with the label of the output. The outputs are taken in +-- order, and one that left for two of them has the label of the first. +-- +-- * A transaction of an abandoned block that the store has as replaced is +-- not in the pool and does not come back to it: the store has imported +-- the new blocks by then, and deleted it. Every store had it confirmed, +-- so every store says the same of it. It was replaced once the tip +-- reaches the block that confirms the transaction that replaced it, which +-- may be in this move or in a later one: the tip may stop at the fork +-- before it goes on. +-- +-- The store labels with the transaction that won and the height of its +-- block, and the pool keeps them for a while, so that a wallet that asks +-- for a transaction that lost is told what won. +advanceReplacing :: + (Ord t, Ord o) => + (o -> t) -> + Change t o -> + (o -> Maybe w) -> + [(t, t, w)] -> + Map t (t, w) -> + Pool t o -> + (Pool t o, [(t, w)], Map t (t, w)) +advanceReplacing maker change label lost waiting pool0 = (final, now <> clashed, still) where back = foldl' comeBack pool0 change.returned -- a transaction that was confirmed has the better claim to what it @@ -225,7 +259,19 @@ orphaned = concatMap (\t -> maybe [] Set.toList (Map.lookup t back.children)) change.gone alive = withdraw orphaned back settled = foldl' (flip remove) alive change.confirmed - clashed = withdraw (mapMaybe (`Map.lookup` settled.spender) change.spent) settled + -- what waits for a transaction that the new blocks confirm was replaced + confirmed = Set.fromList change.confirmed + waitingNow = foldl' (\m (t, by, w) -> Map.insert t (by, w) m) waiting lost + (reached, still) = Map.partition (\(by, _) -> Set.member by confirmed) waitingNow + now = [(t, w) | (t, (_, w)) <- Map.toList reached] + -- what spends an output that the blocks spend leaves, with all that + -- spends it + (final, clashed) = foldl' clash (settled, []) change.spent + clash (p, replaced) o = case Map.lookup o p.spender of + Nothing -> (p, replaced) + Just s -> + let leaving = Set.toList (descendants [s] p) + in (withdraw [s] p, replaced <> maybe [] (\w -> [(t, w) | t <- leaving]) (label o)) -- | What a transaction does at an address, for addresses of type @a@: the -- entries by address of "Haskoin.Store.Database.Mempool", which a store diff --git a/src/Haskoin/Store/Fleet/Redis.hs b/src/Haskoin/Store/Fleet/Redis.hs --- a/src/Haskoin/Store/Fleet/Redis.hs +++ b/src/Haskoin/Store/Fleet/Redis.hs @@ -88,7 +88,7 @@ import Data.ByteString.Char8 qualified as C import Data.FileEmbed (embedFile, makeRelativeToProject) import Data.Maybe (fromMaybe) -import Data.Word (Word64) +import Data.Word (Word32, Word64) import Database.Redis (Connection, Redis, Reply) import Database.Redis qualified as R import Haskoin.Store.Fleet (Time) @@ -218,8 +218,18 @@ gone :: ![ByteString], -- | transactions that the new blocks confirm confirmed :: ![ByteString], - -- | outputs that the new blocks spend - spent :: ![ByteString] + -- | outputs that the new blocks spend, each followed by the transaction + -- of the block that spends it and the height of that block in four + -- bytes, big-endian: what replaces a transaction of the pool that + -- spends it ('Haskoin.Store.Fleet.Pool.advanceReplacing') + spent :: ![ByteString], + -- | the height of the block that the tip moves to, by which what was + -- replaced 2016 blocks before is forgotten, if it is known + height :: !(Maybe Word32), + -- | transactions of the abandoned blocks that the store has as + -- replaced, each followed like an output of 'spent' by what replaced + -- it: kept as replaced once the tip reaches it + lost :: ![ByteString] } deriving (Eq, Show) @@ -279,7 +289,9 @@ [ByteString] -> IO Moved fleetAdvance conn keys tsize clock seen target known = - advance conn keys tsize clock seen target (maybe "1" (const "0") known) (fromMaybe (PoolChange [] [] [] []) known) + advance conn keys tsize clock seen target (maybe "1" (const "0") known) (fromMaybe unchanged known) + where + unchanged = PoolChange [] [] [] [] Nothing [] -- | Move the tip to a block and empty the pool, for a store that has both -- the tip and the block and finds the way between them longer than it @@ -294,7 +306,7 @@ -- count of 'fleetRestarts' went up. fleetRestart :: Connection -> FleetKeys -> Int -> Maybe Time -> Maybe ByteString -> ByteString -> IO Moved fleetRestart conn keys tsize clock seen target = - advance conn keys tsize clock seen target "2" (PoolChange [] [] [] []) [] + advance conn keys tsize clock seen target "2" (PoolChange [] [] [] [] Nothing []) [] -- | How many times the pool was emptied to move the tip. A store that sees -- another number than at its last turn offers all of its mempool again: @@ -325,7 +337,8 @@ where args = ["advance", keys.prefix, num tsize, maybe "" id seen, target, maybe "" num clock, num keys.size, how] - <> [B.concat change.gone, B.concat change.confirmed, B.concat change.spent] + <> [maybe "" num change.height] + <> [B.concat change.gone, B.concat change.confirmed, B.concat change.spent, B.concat change.lost] <> [num (length change.returned)] <> concatMap txArgs change.returned <> [B.concat path] diff --git a/src/Haskoin/Store/Fleet/XPub.hs b/src/Haskoin/Store/Fleet/XPub.hs --- a/src/Haskoin/Store/Fleet/XPub.hs +++ b/src/Haskoin/Store/Fleet/XPub.hs @@ -212,7 +212,8 @@ bodies = return . map (const (Nothing, IntMap.empty)), spenders = return . map (const Nothing), page = \_ _ -> return [], - startingWith = \_ -> return [] + startingWith = \_ -> return [], + replaced = \_ -> return Nothing } ------------------------------------------------------------------------------- diff --git a/src/Haskoin/Store/Fleet/lua/pool.lua b/src/Haskoin/Store/Fleet/lua/pool.lua --- a/src/Haskoin/Store/Fleet/lua/pool.lua +++ b/src/Haskoin/Store/Fleet/lua/pool.lua @@ -26,12 +26,26 @@ -- -- 'advance': the tip that the store saw or '', the block to move to, the -- time in milliseconds or '' for the clock of Redis, the size of a block in --- bytes, '1' to empty the pool instead of changing it or '0', the --- transactions that are gone, those that are confirmed, the outputs that --- are spent, the number of transactions that come back, those --- transactions, and the blocks that the tip moves through, oldest first, --- or ''. Returns {'moved'}, {'stays'} or {'raced'}. +-- bytes, '1' to empty the pool instead of changing it or '0', the height of +-- the block to move to or '', the transactions that are gone, those that +-- are confirmed, the outputs that are spent, each followed by the +-- transaction of the block that spends it and the height of that block in +-- four bytes, big-endian, the transactions of the abandoned blocks that the +-- store has as replaced, each followed in the same way, the number of +-- transactions that come back, those transactions, and the blocks that the +-- tip moves through, oldest first, or ''. Returns {'moved'}, {'stays'} or +-- {'raced'}. -- +-- What the new blocks replaced is kept: each transaction of the pool that +-- leaves because it, or an ancestor, spent an output that a transaction of +-- the blocks spends, with that transaction and the height of its block. +-- A transaction of the abandoned blocks that the store names as replaced +-- waits until a move confirms the transaction that replaced it, and is +-- kept then. What is kept is forgotten when the transaction that replaced +-- it comes back from an abandoned block; it, and what waits, are forgotten +-- 2016 blocks after their height, by the height of the block that the tip +-- moves to. Haskoin.Store.Fleet.Pool.advanceReplacing says the same. +-- -- The pool is emptied instead of changed in two cases. With '1' the store -- cannot say what the blocks between the two tips did, because it does -- not have the old tip: only when no other store is live, and {'raced'} @@ -91,6 +105,12 @@ aval = prefix .. 'pool:aval:', aspent = prefix .. 'pool:aspent:', asum = prefix .. 'pool:asum:', + rep = prefix .. 'pool:rep', + repby = prefix .. 'pool:repby:', + repat = prefix .. 'pool:repat', + lostval = prefix .. 'pool:lost', + lostby = prefix .. 'pool:lostby:', + lostat = prefix .. 'pool:lostat', of = prefix .. 'fx:of:', entry = prefix .. 'fx:e:' } @@ -319,6 +339,30 @@ return withdraw(split(ARGV[4], tsize)) end +-- forget that these transactions were replaced +local function unreplaced(ts) + for _, t in ipairs(ts) do + local value = redis.call('HGET', key.rep, t) + if value then + redis.call('SREM', key.repby .. string.sub(value, 1, tsize), t) + redis.call('HDEL', key.rep, t) + redis.call('ZREM', key.repat, t) + end + end +end + +-- keep that a transaction was replaced: by a transaction, which comes +-- first in the value, at a height, which follows in four bytes. What was +-- kept of it before goes, with its place among what its winner replaced. +local function replaced(t, value) + local by, h = string.sub(value, 1, tsize), string.sub(value, tsize + 1, tsize + 4) + local b1, b2, b3, b4 = string.byte(h, 1, 4) + unreplaced({t}) + redis.call('HSET', key.rep, t, value) + redis.call('SADD', key.repby .. by, t) + redis.call('ZADD', key.repat, ((b1 * 256 + b2) * 256 + b3) * 256 + b4, t) +end + local tip = redis.call('GET', key.tip) or '' if tip ~= ARGV[4] then return {'raced'} @@ -432,11 +476,13 @@ end -- the abandoned blocks: what can come back does, and what spends the rest --- leaves -local at = 13 -for _ = 1, tonumber(ARGV[12]) do +-- leaves. What a transaction that comes back replaced is not replaced any +-- more. +local at = 15 +for _ = 1, tonumber(ARGV[14]) do local tx tx, at = read(at) + unreplaced(redis.call('SMEMBERS', key.repby .. tx.id)) if not member(tx.id) then -- it was confirmed: what spends the same in the pool gives way local rivals = {} @@ -450,8 +496,21 @@ insert(tx) end end +-- what the store has as replaced of the abandoned blocks waits for the +-- transaction that replaced it +for _, item in ipairs(split(ARGV[13], 2 * tsize + 4)) do + local t, value = string.sub(item, 1, tsize), string.sub(item, tsize + 1) + local old = redis.call('HGET', key.lostval, t) + if old then + redis.call('SREM', key.lostby .. string.sub(old, 1, tsize), t) + end + local b1, b2, b3, b4 = string.byte(string.sub(value, tsize + 1, tsize + 4), 1, 4) + redis.call('HSET', key.lostval, t, value) + redis.call('SADD', key.lostby .. string.sub(value, 1, tsize), t) + redis.call('ZADD', key.lostat, ((b1 * 256 + b2) * 256 + b3) * 256 + b4, t) +end local orphaned = {} -for _, t in ipairs(split(ARGV[9], tsize)) do +for _, t in ipairs(split(ARGV[10], tsize)) do for _, kid in ipairs(redis.call('SMEMBERS', key.kids .. t)) do orphaned[#orphaned + 1] = kid end @@ -459,18 +518,38 @@ withdraw(orphaned) -- the new blocks: what they confirm leaves alone, and what spends what they --- spend leaves with all that spends it -for _, t in ipairs(split(ARGV[10], tsize)) do +-- spend leaves with all that spends it, and is kept as replaced +for _, t in ipairs(split(ARGV[11], tsize)) do remove(t, true) end -local clashing = {} -for _, o in ipairs(split(ARGV[11], osize)) do - local s = redis.call('HGET', key.spender, o) +-- what waited for a transaction that they confirm was replaced +for _, t in ipairs(split(ARGV[11], tsize)) do + for _, waiting in ipairs(redis.call('SMEMBERS', key.lostby .. t)) do + replaced(waiting, redis.call('HGET', key.lostval, waiting)) + redis.call('HDEL', key.lostval, waiting) + redis.call('ZREM', key.lostat, waiting) + end + redis.call('DEL', key.lostby .. t) +end +for _, item in ipairs(split(ARGV[12], osize + tsize + 4)) do + local s = redis.call('HGET', key.spender, string.sub(item, 1, osize)) if s then - clashing[#clashing + 1] = s + for _, t in ipairs(withdraw({s})) do + replaced(t, string.sub(item, osize + 1)) + end end end -withdraw(clashing) +-- forget what was replaced, or waits, 2016 blocks before the block of the +-- tip +if ARGV[9] ~= '' and tonumber(ARGV[9]) >= 2016 then + local limit = tonumber(ARGV[9]) - 2016 + unreplaced(redis.call('ZRANGEBYSCORE', key.repat, '-inf', limit)) + for _, t in ipairs(redis.call('ZRANGEBYSCORE', key.lostat, '-inf', limit)) do + redis.call('SREM', key.lostby .. string.sub(redis.call('HGET', key.lostval, t), 1, tsize), t) + redis.call('HDEL', key.lostval, t) + redis.call('ZREM', key.lostat, t) + end +end redis.call('SET', key.tip, target) redis.call('INCR', key.moves) diff --git a/src/Haskoin/Store/Fleet/lua/read.lua b/src/Haskoin/Store/Fleet/lua/read.lua --- a/src/Haskoin/Store/Fleet/lua/read.lua +++ b/src/Haskoin/Store/Fleet/lua/read.lua @@ -34,6 +34,9 @@ -- the newest, an id and a time for each. -- -- 'ids': some bytes. The transactions whose id starts with them. +-- +-- 'replaced': transactions. For each, the transaction of a block that +-- replaced it and the height of the block in four bytes, or ''. local what, prefix, tsize = ARGV[1], ARGV[2], tonumber(ARGV[3]) local osize = tsize + 4 if (redis.call('GET', prefix .. 'fleet:tip') or '') ~= ARGV[4] then @@ -167,6 +170,10 @@ '[' .. ARGV[5], '(' .. ARGV[5] .. string.rep(string.char(255), tsize)) for _, t in ipairs(found) do answer[#answer + 1] = t + end +elseif what == 'replaced' then + for i = 5, #ARGV do + answer[#answer + 1] = redis.call('HGET', prefix .. 'pool:rep', ARGV[i]) or '' end end return answer diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -59,6 +59,7 @@ ( ImportException (..), initBest, revertBlock, + revertBlockAt, importBlock, newMempoolTx, deleteUnconfirmedTx, @@ -236,7 +237,18 @@ -- main chain, move its transactions back to the mempool, and delete its -- coinbase. Throws 'BlockNotBest' if the block is not the best block. revertBlock :: Writer -> BlockHash -> IO () -revertBlock wr bh = do +revertBlock wr = revertWith wr id + +-- | 'revertBlock', with the transactions put back at a time, the time of +-- the revert, as the layered layout puts them back +-- ("Haskoin.Store.Logic.Layered"): the tests compare the two. +revertBlockAt :: Writer -> UnixTime -> BlockHash -> IO () +revertBlockAt wr now = revertWith wr (\td -> (td :: TxData) {timestamp = now}) + +-- | Revert the best block, changing each transaction that goes back to the +-- mempool first. +revertWith :: Writer -> (TxData -> TxData) -> BlockHash -> IO () +revertWith wr restamp bh = do bd <- bestBlockData wr >>= \b -> if headerHash b.header == bh @@ -257,7 +269,7 @@ insertBlock wr bd {main = False} logDebug wr $ "Updated as not in main chain: " <> blockHashToHex bh - forM_ (drop 1 tds) (unConfirmTx wr) + forM_ (drop 1 tds) (unConfirmTx wr . restamp) logDebug wr $ "Unconfirmed " <> cs (show (length tds)) <> " transactions" deleteConfirmedTx wr (txHash (tds !! 0).tx) diff --git a/src/Haskoin/Store/Logic/Layered.hs b/src/Haskoin/Store/Logic/Layered.hs --- a/src/Haskoin/Store/Logic/Layered.hs +++ b/src/Haskoin/Store/Logic/Layered.hs @@ -109,7 +109,7 @@ txHashToHex, ) import Haskoin.Node (LogLevel (..), logAt) -import Haskoin.Store.Common (nub', sortTxs) +import Haskoin.Store.Common (Replaced (..), nub', replacedKept, sortTxs) import Haskoin.Store.Data import Haskoin.Store.Database.Mempool (MemRecords (..), mempoolRecords) import Haskoin.Store.Database.Types (MemAddrKey (..), MemAddrVal (..), MemSummary (..)) @@ -252,6 +252,9 @@ setBlocksAtHeight wr (nub (headerHash n.header : bs)) n.height setBest wr (headerHash n.header) tds <- importTxs wr n b.txs + -- forget what a block replaced 'replacedKept' blocks ago + when (n.height >= replacedKept) $ + getReplacedAt wr (n.height - replacedKept) >>= mapM_ (deleteReplaced wr) let bd = BlockData { height = n.height, @@ -279,7 +282,9 @@ in fromIntegral $ s * 3 + x -- | Import the transactions of a block, in dependency order, after deleting --- the mempool transactions that conflict with them. +-- the mempool transactions that conflict with them. What is kept of each +-- one deleted ('Replaced') names the transaction of the block that it +-- conflicts with, or that its unconfirmed ancestor conflicts with. importTxs :: Writer -> BlockNode -> [Tx] -> IO [TxData] importTxs wr bn txns = do mapM_ (freeOutputs . snd) (reverse txs) @@ -288,7 +293,10 @@ txs = sortTxs txns br i = BlockRef {height = bn.height, position = i} blockTime = fromIntegral bn.header.timestamp - freeOutputs tx = getConflicts wr True False tx >>= mapM_ (deleteSingleTx wr . txHash) + freeOutputs tx = + getConflicts wr True False tx >>= mapM_ (\gone -> do + deleteSingleTx wr (txHash gone) + insertReplaced wr (txHash gone) Replaced {by = txHash tx, height = bn.height}) action i tx = getMempoolTx wr (txHash tx) >>= \case Just td -> do @@ -357,10 +365,19 @@ -- | Revert the best block: make its parent the best block, mark it as not in -- the main chain, take its transactions out of the chain and give them to --- the mempool, and delete its coinbase with whatever spends it. Throws --- 'BlockNotBest' if the block is not the best block. -revertBlock :: Writer -> BlockHash -> IO () -revertBlock wr bh = do +-- the mempool at a time, the time of the revert, and delete its coinbase +-- with whatever spends it. Throws 'BlockNotBest' if the block is not the +-- best block. +-- +-- The transactions go back with the time that they are put back, not that +-- of their block. The mempool deletes what is older than its timeout +-- (@--mempool-timeout@), by that time: with the time of the block, a +-- transaction of a block older than the timeout was deleted as soon as it +-- came back, while the nodes kept it. Stores of a fleet give it the same +-- time all the same, as the shared mempool keeps the time of the first +-- store that offers it. +revertBlock :: Writer -> UnixTime -> BlockHash -> IO () +revertBlock wr now bh = do bd <- bestBlockData wr >>= \b -> if headerHash b.header == bh @@ -371,6 +388,8 @@ tds <- mapM inChain bd.txs setBest wr bd.header.prev insertBlock wr bd {main = False} + -- what the block replaced is not replaced any more + getReplacedAt wr bd.height >>= mapM_ (deleteReplaced wr) case tds of [] -> return () coinbase : rest -> do @@ -380,14 +399,12 @@ ordered = filter ((`M.member` returned) . txHash) (map snd (sortTxs (map (.tx) tds))) -- out of the chain, each after the transactions that spend it forM_ (reverse ordered) (leave . txHash) - -- into the mempool, at the time that each had in the chain, which is - -- that of the block: the time at which a store first saw it is not - -- kept past its confirmation, and every store gives it the same - -- time this way. The coinbase is still in the chain: a transaction that spends it has all its - -- parents while its flag is worked out, as in the layout of version 20 + -- into the mempool, at the time of the revert. The coinbase is still + -- in the chain: a transaction that spends it has all its parents + -- while its flag is worked out, as in the layout of version 20 forM_ (mapMaybe ((`M.lookup` returned) . txHash) ordered) $ \td -> do rbf <- isRBF wr td.tx - addMempoolTx wr td.timestamp (td :: TxData) {rbf = rbf} + addMempoolTx wr now (td :: TxData) {rbf = rbf, timestamp = now} updateSpendersRBF wr td.tx -- a coinbase cannot be in the mempool: it is deleted, and so is -- everything that spends it diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -233,11 +233,13 @@ parseQuery, renderStdMethod, status200, + status202, status203, status204, status400, status404, status409, + status410, status413, status500, status503, @@ -300,6 +302,7 @@ catch, catchAny, checkSTM, + Exception, fromException, handleAny, link, @@ -347,17 +350,13 @@ blockTimeout :: !Word64, -- | seconds that a request may take before the log has a warning -- about it ('logIt') - slowRequest :: !Word32, - -- | seconds that @POST \/transactions@ waits for a node to announce - -- the transaction back ("Haskoin.Store.Web.Publish") - publishTimeout :: !Word32 + slowRequest :: !Word32 } deriving (Eq, Show) -- | 200000 items, 5000 full transactions, offset up to 50000, 100 items by -- default, xpub gaps of 32 and 20, transaction timeout of 30 minutes, --- block timeout of four hours, a warning for requests of five seconds, and --- thirty seconds for a published transaction to come back. +-- block timeout of four hours, and a warning for requests of five seconds. instance Default WebLimits where def = WebLimits @@ -369,8 +368,7 @@ xpubGapInit = 20, txTimeout = 3600 `div` 2, blockTimeout = 4 * 3600, - slowRequest = 5, - publishTimeout = 30 + slowRequest = 5 } -- | Configuration of the web server. @@ -446,9 +444,9 @@ cacheUp :: !(TVar Bool), -- | the events that the clients of @\/events@ read ('feedEvents') eventLog :: !EventLog, - -- | the transactions being published, and those that failed not long - -- ago ("Haskoin.Store.Web.Publish") - outbox :: !(TVar Publish.Outbox) + -- | the transactions that were handed over and that the store asks + -- for until it has them ("Haskoin.Store.Web.Publish") + asking :: !Publish.Asking } -- | StatsD metrics of the web server: a timing for each kind of request, @@ -674,7 +672,7 @@ forM_ config.store.fleet $ \member -> atomically (writeTVar member.healthy (isOK first)) cacheUp <- cacheCheck >>= newTVarIO eventLog <- newEventLog - outbox <- newTVarIO Publish.emptyOutbox + asking <- Publish.newAsking let db = config.store.db stateOf q = WebState {query = webQuery config.store cacheUp q, direct = q, ..} routesOf s = map (guarded s) (concatMap withPost (handlePaths s config)) @@ -749,9 +747,10 @@ withAsync (priceUpdater session ticker) $ \_a1 -> withAsync (healthCheckLoop health cacheUp saidWell saidRedis pinged newBlock) $ \_a2 -> withAsync (feedEvents st) $ \a3 -> - link a3 >> do - let logged = logIt config.logger config.accessLog config.limits.slowRequest - serve . webSocketEvents st . logged . anyOrigin . preflight . autohead . compressed . cappedBody st $ app + withAsync (askingLoop st) $ \_a4 -> + link a3 >> do + let logged = logIt config.logger config.accessLog config.limits.slowRequest + serve . webSocketEvents st . logged . anyOrigin . preflight . autohead . compressed . cappedBody st $ app where priceUpdater session = unless config.noBlockchainInfo @@ -869,10 +868,47 @@ | Just Next <- fromException e = throwIO Next | Just TipMoved <- fromException e = throwIO TipMoved | Just x <- fromException e = errorResponse st x + | Just g <- fromException e = goneResponse st g | otherwise = do logError st.config.logger $ fmtReq req.wai <> ": " <> cs (show e) errorResponse st ServerError +-- | A transaction that a block replaced ('Replaced'), asked for by its id: +-- answered 410, Gone, with the transaction that replaced it and the height +-- of its block, where one that never was is 404. +-- +-- The errors of the API are those of haskoin-store-data, whose client +-- reads them. This one is not among them yet, so it is answered here, in +-- the same form: the client takes it for an error it does not know. +data Gone = Gone !TxHash !Replaced + deriving (Show) + +instance Exception Gone + +-- | The answer to 'Gone', counted with the errors of clients. +goneResponse :: WebState -> Gone -> IO Response +goneResponse st (Gone txid r) = do + forM_ st.metrics $ \m -> incrementCounter m.clientErrors 1 + return . responseLBS status410 [(hContentType, "application/json")] . A.encode $ + A.object + [ "error" .= ("replaced" :: Text), + "message" + .= T.unwords + [ "Transaction", + txHashToHex txid, + "was replaced by", + txHashToHex r.by, + "in the block at height", + T.pack (show r.height) + ], + "replaced-by" .= r.by, + "height" .= r.height + ] + +-- | Not found: 'Gone' if a block replaced the transaction, else 404. +notFoundTx :: WebState -> TxHash -> IO a +notFoundTx st txid = st.query.getReplaced txid >>= maybe (raise st ThingNotFound) (throwIO . Gone txid) + -- | What a store that is a member of a fleet answers when it has no view of -- the block that the fleet answers from: 503, so that a load balancer sends -- the request to another store. Any answer of its own could differ from @@ -1028,7 +1064,7 @@ marshalled ["notx"] (\r -> GetBlock <$> cap r <*> dflt r) (handleBlock st), marshalled [] (\r -> GetTx <$> cap r) (handleTx st), plain [] (\r -> GetTxRaw <$> cap r) (handleTxRaw st), - plain [] (\r -> PostTx <$> parseTxBody st r) (handlePostTx st), + pathPosted [] (\r -> PostTx <$> parseTxBody st r) (handlePostTx st), plainList limits (\r -> GetAddrTxs <$> cap r <*> lim r) (handleAddrTxs st), marshalled [] (\r -> GetAddrBalance <$> cap r) (handleAddrBalance st), marshalledList limits (\r -> GetAddrUnspent <$> cap r <*> lim r) (handleAddrUnspent st), @@ -1204,6 +1240,19 @@ toProxy = const Proxy proxy = toProxy parser +-- | The route of an API resource whose handler chooses the status of its +-- answer: @POST \/transactions@, which answers 202 for a transaction that +-- it handed over. +pathPosted :: (ApiResource a b) => [Text] -> (Req -> IO a) -> (a -> IO (Status, Encoding)) -> Route +pathPosted ps parser action = + route (renderStdMethod (resourceMethod proxy)) (capturePath proxy) ps $ \req -> do + (status, res) <- action =<< parser req + return $ responseLBS status jsonType (encodingToLazyByteString res) + where + toProxy :: (Req -> IO a) -> Proxy a + toProxy = const Proxy + proxy = toProxy parser + -- | The route of an API resource that is answered while it is read, as -- "Haskoin.Store.Web.Pieces" explains: the handler gives the bytes of the -- response in pieces. @@ -1427,7 +1476,7 @@ handleTx :: WebState -> GetTx -> IO Transaction handleTx st (GetTx txid) = withMetrics st (.tx) $ - C.getTransaction st.query txid >>= maybe (raise st ThingNotFound) return + C.getTransaction st.query txid >>= maybe (notFoundTx st txid) return -- | Handler for @GET \/transactions?txids=…@: several transactions. handleTxs :: @@ -1447,7 +1496,7 @@ withMetrics st (.txRaw) $ C.getTransaction st.query txid >>= \case - Nothing -> raise st ThingNotFound + Nothing -> notFoundTx st txid Just tx -> return $ RawResult (transactionData tx) -- | Handler for @GET \/transactions\/raw?txids=…@: several transactions, serialized. @@ -1528,27 +1577,36 @@ -- POST Transaction -- --- | Handler for @POST \/transactions@: hand the transaction to a full node, --- and answer with its hash once a node has announced it back --- ("Haskoin.Store.Web.Publish"). One that the store has unconfirmed is --- handed to a node again, and answered once the node took it. What the --- store or a node refuses is 400 with the reason; no node, no answer and --- no announcement are 500. -handlePostTx :: WebState -> PostTx -> IO TxId +-- | Handler for @POST \/transactions@: check the transaction and hand it +-- over ("Haskoin.Store.Web.Publish"). The answer is 202 with its id and a +-- message once it was handed over, over the RPC of a node or to the peers, +-- and 200 with its id for one that the store has in a block. What the +-- store or a node refuses is 400 with the reason; no peer is 500. +handlePostTx :: WebState -> PostTx -> IO (Status, Encoding) handlePostTx st (PostTx tx) = withMetrics st (.txPost) $ Publish.publish (publishing st) tx >>= \case - Publish.Verdict Publish.Accepted -> return (TxId (txHash tx)) + Publish.InBlock -> return (status200, toEncoding (TxId txid)) + Publish.ToNode -> handed "A full node took the transaction." + Publish.ToPeers n -> + handed . T.unwords $ + [ "Handed over to", + T.pack (show n), + if n == 1 then "peer." else "peers.", + "The network decides whether to take it." + ] Publish.Invalid why -> raise st (UserError (show why)) - Publish.Verdict (Publish.Refused why) -> + Publish.Refused why -> raise st (UserError ("A node refused the transaction: " <> T.unpack why)) - Publish.Verdict (Publish.Unverified i) -> + Publish.Unverified i -> raise st . UserError $ "This server cannot verify the signature of input " <> show i <> ", and sends to its peers only what it has verified" - Publish.Verdict Publish.Silent -> raise st ServerTimeout - _ -> raise st ServerError + Publish.NoPeers -> raise st ServerError + where + txid = txHash tx + handed message = return (status202, A.pairs ("txid" .= txid <> "message" .= (message :: Text))) -- | The chain as the store has it, for the checks of a transaction to -- publish: the height of the best block, and the median of the times of @@ -1586,7 +1644,7 @@ -- It is an option because the store needs nothing of a node but to be -- its peer, and this needs an account on one. A node that does not -- answer, or answers what cannot be read, is 'Publish.Unavailable': the --- transaction then goes to a peer, if the store verified it. A +-- transaction then goes to the peers, if the store verified it. A -- transaction that the node has already was sent. sendNode :: WebState -> String -> Tx -> IO Publish.Direct sendNode st url tx = @@ -1623,31 +1681,17 @@ -- | What "Haskoin.Store.Web.Publish" needs, for a request. -- --- The nodes are the peers of the store that relay transactions, in the --- order of the peer manager. +-- The peers are those of the store that take transactions. A transaction +-- that was handed over is asked for again after the answer +-- ('askingLoop'), unless the store keeps no mempool. publishing :: WebState -> Publish.Publishing publishing st = Publish.Publishing - { limits = - Publish.Limits - { wait = fromIntegral st.config.limits.publishTimeout, - handover = 10, - tries = 2, - capacity = 1000, - memory = 600 - }, - outbox = st.outbox, - rules = chainRules st, + { rules = chainRules st, direct = maybe (\_ -> return Publish.Unavailable) (sendNode st) st.config.nodeRpc, holds = fmap heldOf . st.query.getTxData, coin = Publish.coinOf st.query, - present = \h -> L.withView own.db $ \v -> - maybe False (not . (.deleted)) <$> (L.layeredRead v).getTxData h, - events = own.events, - mempool = not st.config.noMempool, - nodes = - map (.address) . filter (maybe False (.relay) . (.version)) - <$> getPeers own.peerMgr, + peers = map (.address) . filter (maybe False (.relay) . (.version)) <$> getPeers own.peerMgr, courier = Publish.deliver Publish.Courier @@ -1656,6 +1700,7 @@ patience = 10, logger = withSource "Courier" st.config.logger }, + fetch = if st.config.noMempool then \_ -> return () else Publish.askFor st.asking, note = \level -> logAt level (withSource "Publish" st.config.logger) } where @@ -1666,6 +1711,21 @@ | confirmed td.block -> Publish.Confirmed | otherwise -> Publish.Pending Nothing -> Publish.Absent + +-- | Ask for the transactions that were handed over until the store has +-- them ("Haskoin.Store.Web.Publish".'Publish.Asking'): as if each peer had +-- announced them, so that the block store asks one of them. A failure is +-- logged and the asking goes on. +askingLoop :: WebState -> IO () +askingLoop st = forever $ do + tryAny (Publish.askLoop st.asking present ask) >>= \case + Left e -> logWarn (withSource "Publish" st.config.logger) ("Asking for transactions: " <> cs (show e)) + Right () -> return () + threadDelay 1000000 + where + own = st.config.store + present h = L.withView own.db $ \v -> maybe False (not . (.deleted)) <$> (L.layeredRead v).getTxData h + ask h = getPeers own.peerMgr >>= mapM_ (\op -> blockStoreTxHash op.mailbox [h] own.block) -- GET Mempool / Events -- diff --git a/src/Haskoin/Store/Web/Publish.hs b/src/Haskoin/Store/Web/Publish.hs --- a/src/Haskoin/Store/Web/Publish.hs +++ b/src/Haskoin/Store/Web/Publish.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedRecordDot #-} {-# OPTIONS_GHC -Wno-ambiguous-fields #-} @@ -12,158 +13,125 @@ -- -- Publishing a transaction that a client posted: @POST \/transactions@. -- --- = The problem --- --- The store does not run scripts. It can check the signature of a coin --- locked to one key, and cannot tell whether a script of another kind is --- satisfied, so it cannot tell every valid transaction from a forged one. --- Two things follow. It must not put a --- transaction from a client into its mempool, or anyone could show a --- payment that will never confirm. And it must not send one over the --- connections it syncs from: a node that finds a transaction invalid may --- drop every connection from the address that sent it, and Bitcoin Cash --- Node does. --- -- = What it does -- --- The store does not broadcast. It hands the transaction to one full node --- and listens for it to come back: --- -- 1. __Check__ what the store can decide from its own index ('judge'): the -- coins, the amounts, the lock time, the rules of relay that do not --- change, and the signature of every coin locked to one key. A --- transaction that the store has in a block is answered at once. +-- change, the form of the input scripts, the tokens of Bitcoin Cash, and +-- the signature of every coin locked to one key. A transaction that the +-- store has in a block is answered at once, and nothing is sent. -- -- 2. __Send over RPC__, where the store was given the RPC of a full node --- ('Publishing'.@direct@). The node checks everything, says why it --- refuses, and what it refuses costs the store nothing. The next step --- is for when there is no such node, or it does not answer. --- --- 3. __Hand over__ ('deliver'), only a transaction whose every signature --- the store verified: on a connection of its own, the courier, to --- a node that the store syncs from. The transaction, then a @ping@. A --- node handles the messages of a connection in order, so the @pong@ --- says that it is done with the transaction. --- --- 4. __Listen__: the connections that the store syncs from never mentioned --- the transaction, so a node that accepted it announces it there as it --- does any other, and the store imports it as it does any other. That --- announcement, the echo, is the only way into the mempool. +-- ('Publishing'.@direct@). The node checks everything, and says at once +-- whether it took the transaction and why not. It is the only way to +-- publish a spend of a coin that the store cannot verify. -- --- 5. __Answer__ when the transaction is in the mempool, or when the node --- said that it refused it, or after 'Limits'.@wait@ seconds. +-- 3. __Hand it to every peer__ otherwise, if the store verified every +-- input: to all at once, each on a connection of its own ('deliver'), +-- and answer that it was handed over as soon as they took it. What the +-- network does with it is the network's to decide. Bitcoin Core refuses +-- without saying so; Bitcoin Cash Node says why, and if every peer that +-- answered refused it, the answer is that reason. -- --- 6. __Remember__ ('Outbox'): a transaction on its way, and one that was --- refused, are kept for a while by the hash of their bytes. The same --- bytes posted again join the first request, or get its answer, and are --- not sent again. +-- 4. __It comes back__ as any transaction does: a peer that takes it +-- announces it on the connections that the store syncs from, which did +-- not send it, and the store imports it. That takes a moment with a node +-- that whitelists the store, and seconds with one that does not. The +-- store also asks for it a few times ('Asking'), in case none does. -- --- A transaction that the store has in its mempool, unconfirmed, is --- checked and sent again in the same way, and answered from what the node --- did with it: there is no echo to wait for, as the store has it already. --- The store does not hold its mempool to its node's, so it may list a --- transaction that the nodes forgot: after a reorganisation, or when a --- node lost its mempool. Posting it again is how a wallet gets it back to --- them. Answering at once, as for a confirmed one, left the wallet with no --- way out but a fee bump, which Bitcoin Cash does not have, until the --- store dropped the transaction weeks later. It costs a node a --- transaction it may have already, which it ignores. +-- A transaction that the store has unconfirmed is checked and sent again in +-- the same way. The store does not hold its mempool to its node's, so it +-- may list a transaction that the nodes forgot: after a reorganisation, or +-- when a node lost its mempool. Posting it again is how a wallet gets it +-- back to them. -- -- = Why it is this way -- --- * __A connection of its own.__ A node never announces a transaction to --- the connection that gave it, and answers @notfound@ when asked for it --- there until its timer for announcements has run. So on the connection --- that sent it there is no telling what the node made of it. On any --- other connection the store is a peer that does not have the --- transaction, and hears of it by the ordinary relay, which every node --- does. Bitcoin Core does the same for its own transactions when told --- to broadcast them privately. --- --- * __The transaction, not an announcement of it.__ A node waits two --- seconds before asking a peer it did not choose for what it announced, --- and does not ask at all for what it knows or has refused. +-- * __No waiting for the echo.__ Until 1.12.1 the request waited, up to +-- @--publish-timeout@, for a node to announce the transaction back, and +-- said what came of it. The wait was arbitrary, Bitcoin Core does not say +-- when it refuses, and the store cannot see the network: a transaction +-- that one node refuses may be taken by others. The client is told what +-- the store knows, that it was handed over, and finds out the rest the +-- way it finds out about any transaction. -- --- * __One node.__ What is sent to one node reaches the others if it is --- good. Sending it to many spreads what is bad. +-- * __A connection of its own.__ A node never announces a transaction to +-- the connection that gave it, and gives it back there only once it +-- relayed it to another peer, or announced something else there. Sent on +-- the connections that the store syncs from, a transaction did not come +-- back to a store whose node had no other peer until a block confirmed +-- it. On a connection of its own it comes back as any other. -- --- * __No breaker.__ A node that closes the courier on a transaction has --- found it invalid, and may have closed the other connections from this --- address too. That transaction is not sent again. The store does not --- stop publishing the others: someone who posts forged transactions --- would then keep everyone else from publishing, which is worse than --- what it guards against. The store connects to its node again, and a --- node that whitelists the store closes nothing. +-- * __Every peer.__ A peer that is sent a transaction it finds invalid may +-- close its connections to the sender, and Bitcoin Cash Node closes them +-- all. So the store sends a peer only what it verified, and checks the +-- rules whose breach was measured to cost it its connections: the form of +-- the input scripts and the tokens ("docs/publishing.md" has what was +-- measured). A transaction that only breaks a rule of relay, such as one +-- that pays too little, is refused by the nodes without harm. -- --- The alternatives: sending through a node's RPC would make the store --- need an account on a node, where it needs only to be a peer; the RPC is --- an option, to ask before sending. Running scripts here would need an --- interpreter of every script of both chains, held to the nodes rule for --- rule; the store checks a signature where there is no script to run. --- Giving the transaction to --- half the peers and listening on the others needs two peers, and puts the --- connections that the store syncs from at risk. +-- * __The RPC first.__ A node that the store can ask says no with a reason, +-- from Bitcoin Core too, and runs every script. -- -- = What it cannot do -- --- Only a full node runs a script. A peer that is sent a transaction it --- finds invalid may drop every connection of the sender, so the store --- sends a peer only what it verified, and refuses a spend of a coin --- that a script locks unless it has the RPC of a node to send it over. A node that --- whitelists the store never does, and announces without delay, so a --- store should be whitelisted by the nodes it is run next to. Bitcoin --- Core does not say to a peer when it refuses a transaction: the client --- learns it when the wait is over, unless the store asks over RPC. +-- Only a full node runs a script. The store refuses a spend of a coin that +-- a script locks unless it has the RPC of a node to send it over. It does +-- not know whether the network took a transaction until it sees it: a +-- client that wants to know watches for it, or posts it again. module Haskoin.Store.Web.Publish ( -- * Publishing Publishing (..), - Limits (..), Answer (..), - Verdict (..), Direct (..), Held (..), publish, + -- * The courier + Delivery (..), + Courier (..), + deliver, + + -- * Asking for what was handed over + Asking, + newAsking, + askFor, + askLoop, + askAgain, + due, + -- * What the store can check Coin (..), Refusal (..), Rules (..), judge, + tokenRules, isDust, maxStandardSize, coinOf, maxTxSize, - - -- * What is on its way - Outbox, - Slot (..), - Ticket (..), - emptyOutbox, - enter, - settle, - - -- * The courier - Delivery (..), - Courier (..), - deliver, ) where -import Control.Monad (unless, when) +import Control.Monad (forM_, forever, unless, when) +import Data.Bits (shiftL, (.&.), (.|.)) +import Data.ByteString (ByteString) import Data.ByteString qualified as B import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap -import Data.Maybe (listToMaybe) -import Data.Serialize (encode) +import Data.List (partition) +import Data.Maybe (isJust, listToMaybe) +import Data.Serialize (decode, encode) import Data.String.Conversions (cs) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T -import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Data.Word (Word32, Word64) +import Data.Word (Word32, Word64, Word8) import Haskoin - ( Hash256, + ( BlockHeight, + InputVerdict (..), Message (..), MessageCommand (..), Network (..), @@ -172,16 +140,17 @@ Ping (..), Pong (..), Reject (..), + Script (..), Tx (..), TxHash, - BlockHeight, - InputVerdict (..), TxIn (..), TxOut (..), VarString (..), - doubleSHA256, + isMinimalPush, + isPushOp, nullOutPoint, sockToHostAddress, + splitTokenPrefix, txHash, txHashToHex, ) @@ -198,21 +167,19 @@ wrapPeer, ) import Haskoin.Node.Peer.Lock (Lock (..)) -import Haskoin.Store.Common (StoreEvent (..), StoreRead (..)) +import Haskoin.Store.Common (StoreRead (..)) import Haskoin.Store.Data (BlockRef (..), Spender (..), TxData (..), isCoinbaseTx) -import NQE (Publisher, newMailbox, receive, withPublisher, withSubscription) +import NQE (newMailbox, receive, withPublisher, withSubscription) import Network.Socket (SockAddr (..)) import System.Random (randomIO) import UnliftIO - ( STM, - TVar, + ( TVar, atomically, + mapConcurrently, + modifyTVar', newTVarIO, - onException, race, - readTVar, readTVarIO, - retrySTM, stateTVar, timeout, waitCatch, @@ -221,38 +188,6 @@ ) import UnliftIO.Concurrent (threadDelay) --- | How long to wait, and how much to remember. -data Limits = Limits - { -- | seconds that a request waits for the transaction to come back - wait :: !NominalDiffTime, - -- | seconds that the courier may take to connect and hand over - handover :: !NominalDiffTime, - -- | nodes to try when one cannot be reached - tries :: !Int, - -- | transactions that the outbox holds; more are turned away - capacity :: !Int, - -- | seconds that an answer other than success is remembered - memory :: !NominalDiffTime - } - deriving (Eq, Show) - --- | What a full node, or the lack of one, made of a transaction. -data Verdict - = -- | a node announced it back, or the store has it - Accepted - | -- | a node refused it and said why - Refused !Text - | -- | a node closed the connection on receiving it - Dropped - | -- | no node could be reached - Unreachable - | -- | a node took it and nothing came back in time - Silent - | -- | not sent: the store could not verify the signature of this input, - -- and had no node to give the transaction to over RPC - Unverified !Int - deriving (Eq, Show) - -- | Whether the store has a transaction, and where. data Held = -- | the store does not have it @@ -276,12 +211,22 @@ -- | The answer to a request to publish. data Answer - = -- | what came of handing it to a node - Verdict !Verdict + = -- | the store has it in a block: nothing was sent + InBlock + | -- | a full node took it over its RPC + ToNode + | -- | handed to this many peers + ToPeers !Int + | -- | a full node refused it over its RPC and said why, or every peer + -- that answered refused it + Refused !Text | -- | refused by the store, before anything was sent Invalid !Refusal - | -- | the outbox is full - Busy + | -- | not sent: the store could not verify the signature of this input, + -- and had no node to give the transaction to over RPC + Unverified !Int + | -- | not handed over: the store has no peer, or reached none + NoPeers deriving (Eq, Show) -- | An output that a transaction spends, as the store knows it. @@ -317,6 +262,11 @@ | TooHeavy !Int | Dust !Int | Forged !Int + | BadVersion !Word32 + | NotPushOnly !Int + | NotMinimal !Int + | BadTokens !Int + | TokensUnbacked !String deriving (Eq) instance Show Refusal where @@ -337,6 +287,11 @@ show (TooHeavy n) = "The transaction is larger than nodes relay: " <> show n show (Dust i) = "Output " <> show i <> " is worth less than it costs to spend, and nodes do not relay it" show (Forged i) = "The signature of input " <> show i <> " does not verify" + show (BadVersion v) = "Nodes do not take a transaction of version " <> show v + show (NotPushOnly i) = "The script of input " <> show i <> " does more than push data" + show (NotMinimal i) = "The script of input " <> show i <> " pushes data in a longer form than it needs" + show (BadTokens i) = "The tokens of output " <> show i <> " are not written as tokens are" + show (TokensUnbacked c) = "The transaction gives tokens of category " <> c <> " that its inputs do not hold" showOutPoint :: OutPoint -> String showOutPoint o = cs (txHashToHex o.hash) <> ":" <> show o.index @@ -386,6 +341,14 @@ -- output so small that spending it costs more than it holds ('isDust'). -- These are rules of relay and not of the chain; they are the ones that -- have not changed in years. +-- * __Input scripts__ only push data, each push in its shortest form. On +-- Bitcoin Cash that is a rule of the chain, and a node drops every +-- connection of a peer that sends a transaction that breaks it. +-- * __The version__: 1 or 2 on Bitcoin Cash, a rule of the chain there; 1 +-- to 3 on Bitcoin, which nodes relay. +-- * __Tokens__ of Bitcoin Cash ('tokenRules'): written as tokens are, and +-- given only as the inputs hold them. A node drops every connection of a +-- peer that sends a transaction that breaks them. -- * __Signatures__, where there is no script to run: an input that spends -- a coin locked to one key with a signature that does not verify -- ('judgeInputs' of haskoin-core). An input that is a script, or that @@ -407,7 +370,10 @@ when (null tx.outputs) $ Left NoOutputs when (any ((== nullOutPoint) . (.outpoint)) tx.inputs) $ Left IsCoinbase mapM_ (Left . DuplicateInput) (firstDuplicate (map (.outpoint) tx.inputs)) + unless (tx.version `elem` versions) $ Left (BadVersion tx.version) + mapM_ pushes (zip [0 ..] tx.inputs) spent <- mapM known (zip (map (.outpoint) tx.inputs) coins) + when cash $ tokenRules tx spent -- sums of 64-bit values: compared as integers, which do not wrap unless (sum (map (toInteger . (.value)) spent) >= sum (map (toInteger . (.value)) tx.outputs)) $ Left Overspent mapM_ mature (zip (map (.outpoint) tx.inputs) coins) @@ -418,6 +384,20 @@ mapM_ (Left . Forged) (take 1 [i | (i, InputForged) <- verdicts]) return (listToMaybe [i | (i, InputUndecided) <- verdicts]) where + cash = isJust rules.net.sigHashForkId + -- Bitcoin Cash takes versions 1 and 2 only, by its rules since May + -- 2023; Bitcoin Core relays those and version 3 + versions + | cash = [1, 2] + | otherwise = [1, 2, 3] + -- an input script that only pushes data, each push in its shortest + -- form: rules of Bitcoin Cash, relay rules of Bitcoin Core + pushes (i, input) = case decode input.script of + Right (Script ops) + | not (all isPushOp ops) -> Left (NotPushOnly i) + | not (all isMinimalPush ops) -> Left (NotMinimal i) + | otherwise -> Right () + Left _ -> Left (NotPushOnly i) size = B.length (encode tx) -- what the limit of relay counts: weight with SegWit, bytes without heavy @@ -501,81 +481,10 @@ confirmed BlockRef {height} = Just height confirmed MemRef {} = Nothing --- | A transaction of the outbox. -data Slot - = -- | a request is publishing it - Flying - | -- | what came of it - Done !Verdict - deriving (Eq, Show) - --- | The transactions on their way and those that failed not long ago, by --- the hash of their bytes. --- --- The hash is of the bytes as posted, witness included. By the --- transaction id, someone could post a transaction of another with its --- witness spoiled, and have the good one answered as refused. -data Outbox = Outbox - { slots :: !(HashMap Hash256 (UTCTime, Slot)) - } - deriving (Eq, Show) - --- | An outbox with nothing on its way. -emptyOutbox :: Outbox -emptyOutbox = Outbox HashMap.empty - --- | What a request is told when it comes with a transaction. -data Ticket - = -- | publish it: it has a slot now - Fresh - | -- | another request is publishing it: wait for that one - Joined - | -- | it failed not long ago, this way - Known !Verdict - | -- | no room - Full - deriving (Eq, Show) - --- | Come with a transaction. What is too old is forgotten first. -enter :: Limits -> UTCTime -> Hash256 -> Outbox -> (Ticket, Outbox) -enter limits now key old = - case HashMap.lookup key box.slots of - Just (_, Flying) -> (Joined, box) - Just (_, Done v) -> (Known v, box) - Nothing - | HashMap.size box.slots >= limits.capacity -> (Full, box) - | otherwise -> (Fresh, box {slots = HashMap.insert key (now, Flying) box.slots}) - where - box = Outbox {slots = HashMap.filter kept old.slots} - -- a request that died without settling does not hold its slot for ever - kept (t, Flying) = diffUTCTime now t < limits.wait + 2 * limits.handover * fromIntegral limits.tries + 60 - kept (t, Done _) = diffUTCTime now t < limits.memory - --- | Say what came of a transaction. Success and a node that could not be --- reached are not remembered: the first is in the database, and the --- second is worth trying again at once. They stay only long enough for --- the requests that joined to read them ('enter' forgets them). -settle :: UTCTime -> Hash256 -> Verdict -> Outbox -> Outbox -settle now key v box = - box - { slots = HashMap.insert key (stamp, Done v) box.slots - } - where - stamp = case v of - Accepted -> long - Unreachable -> long - -- the node may answer over RPC the next time - Unverified _ -> long - _ -> now - -- older than any memory - long = addUTCTime (-1000000000) now - --- | What publishing needs. The courier and the nodes are functions, so +-- | What publishing needs. The peers and the courier are functions, so -- that the rules can be tested without a network. data Publishing = Publishing - { limits :: !Limits, - outbox :: !(TVar Outbox), - -- | the chain as the store has it now + { -- | the chain as the store has it now rules :: !(IO Rules), -- | give the transaction to a full node over its RPC, where the store -- was given the RPC of one @@ -585,17 +494,14 @@ holds :: !(TxHash -> IO Held), -- | the coin of an output, from the queries of the request ('coinOf') coin :: !(OutPoint -> IO Coin), - -- | whether the store has the transaction now, read anew: the queries - -- of a request see the database as it was when the request came - present :: !(TxHash -> IO Bool), - -- | what the store tells its clients - events :: !(Publisher StoreEvent), - -- | whether the store has a mempool to see the transaction come into - mempool :: !Bool, - -- | the nodes to hand a transaction to, the first first - nodes :: !(IO [SockAddr]), - -- | hand a transaction to a node + -- | the addresses of the peers that the store has now, that take + -- transactions + peers :: !(IO [SockAddr]), + -- | hand a transaction to a peer on a connection of its own ('deliver') courier :: !(SockAddr -> Tx -> IO Delivery), + -- | ask for a transaction that was handed over, after the answer: see + -- 'Asking'. It must not wait. + fetch :: !(TxHash -> IO ()), note :: !(LogLevel -> Text -> IO ()) } @@ -603,105 +509,205 @@ publish :: Publishing -> Tx -> IO Answer publish p tx = p.holds txid >>= \case - Confirmed -> return (Verdict Accepted) - held -> + Confirmed -> return InBlock + _ -> (judge <$> p.rules <*> pure tx <*> mapM (p.coin . (.outpoint)) tx.inputs) >>= \case Left r -> return (Invalid r) - Right unverified -> do - now <- getCurrentTime - atomically (stateTVar p.outbox (enter p.limits now key)) >>= \case - Full -> p.note LevelWarn "Outbox full: transaction turned away" >> return Busy - Joined -> Verdict <$> joined - -- sent already, and the node may only have been slow to announce - Known Silent -> Verdict <$> listening (return Silent) - Known v -> return (Verdict v) - Fresh -> do - let go - | held == Pending = again unverified - | otherwise = listening (send unverified) - v <- go `onException` done Unreachable - done v - say v - return (Verdict v) + Right unverified -> + p.direct tx >>= \case + Sent -> do + p.note LevelDebug ("A node took " <> name <> " over its RPC") + p.fetch txid + return ToNode + Declined why -> do + p.note LevelInfo ("A node refused " <> name <> ": " <> why) + return (Refused why) + Unavailable -> case unverified of + Just i -> do + p.note LevelInfo ("Not sent to a peer, input " <> T.pack (show i) <> " not verified: " <> name) + return (Unverified i) + Nothing -> do + addresses <- p.peers + delivered <- mapConcurrently (\a -> p.courier a tx) addresses + let handed = length [() | d <- delivered, d `elem` [Took, NoAnswer]] + reasons = [why | Rejected why <- delivered] + if + | handed > 0 -> do + p.note LevelDebug ("Handed " <> name <> " to " <> T.pack (show handed) <> " peers") + p.fetch txid + return (ToPeers handed) + | why : _ <- reasons -> do + p.note LevelInfo ("Every peer refused " <> name <> ", the first: " <> why) + return (Refused why) + | Closed `elem` delivered -> do + p.note LevelWarn ("A peer closed the connection on receiving " <> name) + return (Refused "a peer closed the connection on receiving it") + | otherwise -> do + p.note LevelWarn ("No peer to hand " <> name <> " to") + return NoPeers where txid = txHash tx - key = doubleSHA256 (encode tx) name = txHashToHex txid - done v = do - now <- getCurrentTime - atomically (stateTVar p.outbox (\b -> ((), settle now key v b))) - joined = - timeout (seconds (p.limits.wait + 2 * p.limits.handover)) (atomically (slotDone p.outbox key)) >>= \case - Just (Just v) -> return v - -- forgotten already: it was accepted, or no node was reached - Just Nothing -> (\has -> if has then Accepted else Unreachable) <$> p.present txid - Nothing -> return Silent - -- Listen before sending, so that the echo cannot come unheard, and - -- look again for the transaction once listening: it may have come - -- since the request read the database. - listening send = - withSubscription p.events $ \sub -> - p.present txid >>= \case - True -> return Accepted - False -> - send >>= \case - Silent - | not p.mempool -> return Accepted - | otherwise -> - timeout (seconds p.limits.wait) (echo sub) >>= \case - Just () -> return Accepted - -- an event may have been missed, never a transaction - Nothing -> (\has -> if has then Accepted else Silent) <$> p.present txid - v -> return v - -- The store has it in its mempool, so no echo will come: what the node - -- took is accepted. - again unverified = - send unverified >>= \case - Silent -> return Accepted - v -> return v - echo sub = - receive sub >>= \case - StoreMempoolNew h | h == txid -> return () - _ -> echo sub - -- Over the RPC of a node if the store has one that answers: the node - -- checks everything, says why it refuses, and nothing it refuses - -- costs the store its connections. Else to a peer, and then only what - -- the store verified itself. - send unverified = - p.direct tx >>= \case - Sent -> return Silent - Declined why -> return (Refused why) - Unavailable -> maybe handOver (return . Unverified) unverified - -- 'Silent' here: the node has it, and has not said that it refused it - handOver = p.nodes >>= go . take p.limits.tries - where - go [] = return Unreachable - go (sa : more) = - p.courier sa tx >>= \case - Took -> return Silent - NoAnswer -> return Silent - Rejected why -> return (Refused why) - Closed -> return Dropped - NoConnection -> go more - say Accepted = p.note LevelDebug ("Published " <> name) - say (Refused why) = p.note LevelInfo ("A node refused " <> name <> ": " <> why) - say Dropped = p.note LevelWarn ("A node closed the connection on receiving " <> name) - say Unreachable = p.note LevelWarn ("No node to publish " <> name <> " to") - say (Unverified i) = - p.note LevelInfo ("Not sent to a peer, input " <> T.pack (show i) <> " not verified: " <> name) - say Silent = p.note LevelInfo ("No node announced " <> name <> " after taking it") --- | Wait for a transaction that another request is publishing. -slotDone :: TVar Outbox -> Hash256 -> STM (Maybe Verdict) -slotDone var key = - HashMap.lookup key . (.slots) <$> readTVar var >>= \case - Just (_, Flying) -> retrySTM - Just (_, Done v) -> return (Just v) - Nothing -> return Nothing +-- | The transactions that were handed over and that the store asks for +-- until it has them, each with when to ask next and the delays after that +-- ('askAgain'). +-- +-- The store asks its peers as if they had announced the transaction, so +-- that it is requested and imported as any other. A peer gives it back +-- once it would announce it: Bitcoin Cash Node in a second or two, Bitcoin +-- Core once it has announced something to the store since it took the +-- transaction, which on a busy network is a matter of seconds. +-- +-- One thread of the web server asks ('askLoop'), and stops with it: a +-- thread for each transaction could outlive the database that it reads. +newtype Asking = Asking (TVar (HashMap TxHash (UTCTime, [NominalDiffTime]))) -seconds :: NominalDiffTime -> Int -seconds t = max 0 (round (t * 1000000)) +-- | Nothing to ask for. +newAsking :: IO Asking +newAsking = Asking <$> newTVarIO HashMap.empty +-- | The most transactions asked for at once. Past it a transaction is not +-- asked for, and comes to the store when a peer announces it or a block +-- confirms it. +askingLimit :: Int +askingLimit = 10000 + +-- | Ask for a transaction from now on, on the schedule of 'askAgain'. +askFor :: Asking -> TxHash -> IO () +askFor (Asking var) h = do + now <- getCurrentTime + atomically . modifyTVar' var $ \m -> case askAgain of + first : rest | HashMap.size m < askingLimit -> HashMap.insert h (addUTCTime first now, rest) m + _ -> m + +-- | The transactions whose time to be asked for has come, and what is left +-- to ask for after them: each at its next delay, or no more after its last. +due :: + UTCTime -> + HashMap TxHash (UTCTime, [NominalDiffTime]) -> + ([TxHash], HashMap TxHash (UTCTime, [NominalDiffTime])) +due now m = ([h | (h, (t, _)) <- HashMap.toList m, t <= now], HashMap.mapMaybe next m) + where + next (t, ds) + | t > now = Just (t, ds) + | otherwise = case ds of + d : rest -> Just (addUTCTime d now, rest) + [] -> Nothing + +-- | Every second, ask for each transaction whose time has come, unless the +-- store has it now. Runs until it is cancelled. +askLoop :: Asking -> (TxHash -> IO Bool) -> (TxHash -> IO ()) -> IO () +askLoop (Asking var) present ask = forever $ do + threadDelay 1000000 + now <- getCurrentTime + ready <- atomically (stateTVar var (due now)) + forM_ ready $ \h -> + present h >>= \case + True -> atomically (modifyTVar' var (HashMap.delete h)) + False -> ask h + +-- | When to ask for a transaction that was handed over: soon, for Bitcoin +-- Cash Node, and then every 25 seconds for two minutes and a half. The +-- delays are longer than the 20 seconds that the block store waits for a +-- transaction that it requested before it asks again. +askAgain :: [NominalDiffTime] +askAgain = [2, 25, 25, 25, 25, 25, 25] + +-- | The tokens that an output holds: their category, a non-fungible token +-- with its capability and commitment, and an amount of fungible ones. +data Tokens = Tokens + { category :: !ByteString, + nft :: !(Maybe (Word8, ByteString)), + amount :: !Word64 + } + +-- | The tokens at the front of the script of an output, if it has any, or +-- 'Left' if they are not written as tokens are ('splitTokenPrefix'). +readTokens :: ByteString -> Either () (Maybe Tokens) +readTokens script = case splitTokenPrefix script of + Nothing -> Left () + Just (prefix, _) + | B.null prefix -> Right Nothing + | otherwise -> Right (Just (parse prefix)) + where + -- the prefix is well formed: 'splitTokenPrefix' said so + parse prefix = + let flags = B.index prefix 33 + rest0 = B.drop 34 prefix + (commitment, rest1) + | flags .&. 0x40 /= 0 = let (n, r) = compact rest0 in B.splitAt (fromIntegral n) r + | otherwise = (B.empty, rest0) + held + | flags .&. 0x10 /= 0 = fst (compact rest1) + | otherwise = 0 + in Tokens + { category = B.take 32 (B.drop 1 prefix), + nft = if flags .&. 0x20 /= 0 then Just (flags .&. 0x0f, commitment) else Nothing, + amount = held + } + compact :: ByteString -> (Word64, ByteString) + compact b = case B.uncons b of + Just (w, r) + | w < 0xfd -> (fromIntegral w, r) + | w == 0xfd -> sized 2 r + | w == 0xfe -> sized 4 r + | otherwise -> sized 8 r + Nothing -> (0, B.empty) + sized :: Int -> ByteString -> (Word64, ByteString) + sized k r = (B.foldr (\w acc -> acc `shiftL` 8 .|. fromIntegral w) 0 (B.take k r), B.drop k r) + +-- | The rules of the tokens of Bitcoin Cash (CashTokens, since May 2023), +-- given the outputs that the inputs spend, in order. A node drops every +-- connection of a peer that sends it a transaction that breaks them, so +-- the store checks them before it sends anything. +-- +-- * The tokens of every output are written as tokens are. +-- * A category is new when it is the id of a transaction whose first +-- output an input spends: its tokens may be made at will. +-- * Of any other category, the outputs hold no more fungible tokens than +-- the inputs, and no more than the largest amount, in all. +-- * And its non-fungible tokens come from the inputs: any, when an input +-- holds one that can mint; else each output's equals one of an input +-- that cannot be changed, or takes the place of one that can be changed, +-- and none can mint. +tokenRules :: Tx -> [TxOut] -> Either Refusal () +tokenRules tx spent = do + outs <- mapM readOut (zip [0 ..] tx.outputs) + let ins = [t | Right (Just t) <- map (readTokens . (.script)) spent] + made = [t | Just t <- outs] + new = [encode i.outpoint.hash | i <- tx.inputs, i.outpoint.index == 0] + categories = HashMap.keys (HashMap.fromList [(t.category, ()) | t <- made]) + forM_ categories $ \c -> do + let given = [t | t <- made, t.category == c] + held = [t | t <- ins, t.category == c] + total = sum (map (toInteger . (.amount)) given) + when (total > 0x7fffffffffffffff) $ Left (TokensUnbacked (named c)) + unless (c `elem` new) $ do + when (total > sum (map (toInteger . (.amount)) held)) $ Left (TokensUnbacked (named c)) + unless (nftsBacked [n | Just n <- map (.nft) given] [n | Just n <- map (.nft) held]) $ + Left (TokensUnbacked (named c)) + where + readOut (i, o) = either (const (Left (BadTokens i))) Right (readTokens o.script) + -- the id of a category as people write it: the bytes reversed + named = concatMap hex . B.unpack . B.reverse + hex w = [digits !! fromIntegral (w `div` 16), digits !! fromIntegral (w `mod` 16)] + digits = "0123456789abcdef" + -- capabilities: 0 none, 1 mutable, 2 minting + nftsBacked given held + | any ((== 2) . fst) held = True + | any ((== 2) . fst) given = False + | otherwise = + let (fixed, changing) = partition ((== 0) . fst) given + left = foldl matched ([n | n <- held, fst n == 0], []) fixed + mutable = length (filter ((== 1) . fst) held) + in length (snd left) + length changing <= mutable + -- an immutable token given takes an equal one held, or waits for a + -- mutable one + matched (pool, unmatched) n = case break (== n) pool of + (before, _ : after) -> (before <> after, unmatched) + _ -> (pool, n : unmatched) + -- | What a node did with a transaction handed to it. data Delivery = -- | it answered the ping that followed: it is done with the @@ -794,3 +800,6 @@ (Nothing, Just (Right ())) -> Took (Nothing, Just (Left ())) -> if was then Closed else NoConnection (Nothing, Nothing) -> if was then NoAnswer else NoConnection + +seconds :: NominalDiffTime -> Int +seconds t = max 0 (round (t * 1000000)) diff --git a/swagger.yaml b/swagger.yaml --- a/swagger.yaml +++ b/swagger.yaml @@ -11,7 +11,7 @@ - url: './' info: - version: &version 1.12.1 + version: &version 1.13.0 title: Haskoin contact: name: JP Rupp @@ -130,6 +130,7 @@ | 400 | `user-error`, `bad-request` | A parameter or the body is wrong; the message says which. | | 404 | `not-found-or-invalid-arg` | The thing does not exist, or a value in the path is not valid. | | 409 | `multiple-tx-index` | A short transaction number matches several transactions. | + | 410 | `replaced` | A transaction asked for by its id was replaced by one that a block confirmed; `replaced-by` and `height` say which and where. | | 500 | `server-error` | Something went wrong on the server; it is logged there. | | 503 | | From `/health`: the server is not ready. | | 503 | `behind-fleet` | The server is one of a fleet and does not have the block that the fleet answers from; another server of the fleet does. | @@ -160,8 +161,22 @@ confirms another transaction that spends the same coins, or, on BTC, when a replacement that pays a higher fee arrives (replace-by-fee). It is then removed from every balance and history, together with any transaction that - spends its outputs. From then on the server answers as if it had never - seen it: fetching it by its id gives 404. Earlier versions answered with + spends its outputs. It is no longer in any answer that lists + transactions. + + Fetched by its id, a transaction that a block replaced gives 410, Gone, + for 2016 blocks, with the transaction of the block that replaced it, or + that replaced the unconfirmed transaction whose outputs it spent: + + ```json + {"error": "replaced", "message": "Transaction … was replaced by … in the block at height 977130", + "replaced-by": "", "height": 977130} + ``` + + After that, and for one replaced in the mempool by a higher fee, the + answer is 404, as for a transaction the server never saw. If the block is + undone by a reorganisation, so is the 410. The servers of a fleet + answer alike, from what the fleet keeps. Earlier versions answered with the transaction and `"deleted": true`, which clients that did not look at that field took for a pending payment. @@ -1763,6 +1778,12 @@ application/json: schema: $ref: '#/components/schemas/Error' + '410': + description: A block replaced the transaction; see Unconfirmed transactions. + content: + application/json: + schema: + $ref: '#/components/schemas/Error' '/transaction/{txid}/raw': get: @@ -1797,6 +1818,12 @@ application/json: schema: $ref: '#/components/schemas/Error' + '410': + description: A block replaced the transaction; see Unconfirmed transactions. + content: + application/json: + schema: + $ref: '#/components/schemas/Error' '/transaction/{txid}/after/{height}': get: @@ -1957,27 +1984,26 @@ must be in the format that nodes of the network read: on BCH, which has no SegWit, the format without witness data. - **A 200 means that a full node accepted the transaction and that this - server has it**: the next request for the transaction, or for a balance - it changes, shows it. + **A 202 means that the transaction was handed over**: to a full node + over RPC, or to the peers of this server. It does not say that the + network took it. A node that takes it announces it, and this server + has it from then on, usually within a second, and seconds with + nodes that do not whitelist this server. - The server does not broadcast. It checks what it can by itself: that - the inputs exist and are not spent, the amounts, the lock time, the - size and dust rules of relay, and the signature of every input that - spends a coin locked to one key. It does not run other scripts: a - transaction with an input it cannot verify is published only by a - server that reaches a full node over RPC, and refused by others. - Then it hands the transaction to one full node, and answers - when a node has announced it back, which is how it enters the mempool of - this server. That takes milliseconds when the node whitelists the server, - and seconds otherwise. + The server checks what it can by itself: that the inputs exist and + are not spent, the amounts, the lock time, the version, that the + input scripts only push data in its shortest form, the tokens of + Bitcoin Cash, the size and dust rules of relay, and the signature of + every input that spends a coin locked to one key. It does not run + other scripts: a transaction with an input it cannot verify is + published only by a server that reaches a full node over RPC, and + refused by others. Then it hands the transaction to every peer, each + on a connection of its own, and answers as soon as they took it. A transaction that this server has in a block is answered 200 and not - sent. One that it has unconfirmed is checked and handed to a full node - again, and answered 200 when the node took it: the nodes may have - forgotten a transaction that this server lists, after a reorganisation - or when a node lost its mempool, and posting it again gets it back to - them. Posting the same transaction again is always safe. + sent. One that it has unconfirmed is handed over again, as the nodes + may have forgotten it: after a reorganisation, or when a node lost + its mempool. Posting the same transaction again is always safe. operationId: postTransaction requestBody: description: >- @@ -1999,8 +2025,19 @@ 04e444809abd438d85eb18e8d07c796e364afe88ac399b7c00000000001976a9\ 1486a7f1a2047ed6719fa1ad5484f15c37c104887c88ac00000000" responses: + '202': + description: | + Handed over. `message` says to whom: a full node over RPC, or + how many peers took it. + content: + application/json: + schema: + $ref: '#/components/schemas/TxId' + example: + txid: 0b7cb07d848959fbd02ad6e2ed21fac888b8e8011c6b8c5362d05c703066ae67 + message: Handed over to 8 peers. The network decides whether to take it. '200': - description: A full node accepted the transaction, and this server has it. + description: This server has the transaction in a block, and sent nothing. content: application/json: schema: @@ -2014,16 +2051,22 @@ * The body is not one transaction in hexadecimal. * It spends an output that this server does not know, or that a confirmed transaction has spent, or a coinbase that is not a - hundred blocks old. + hundred blocks old. The output of a transaction that was handed + over is known once a node has announced it. * Its outputs are worth more than its inputs, its lock time has - not passed, it is larger than nodes relay, or one of its - outputs is dust. + not passed, its version is not one that nodes take, it is + larger than nodes relay, or one of its outputs is dust. + * An input script does more than push data, or pushes it in a + longer form than it needs. + * On Bitcoin Cash, its outputs give tokens that its inputs do not + hold, or tokens not written as tokens are. * The signature of an input that spends a coin locked to one key does not verify. * This server cannot verify the signature of an input, such as one of a script that is not a key or a multisig, and has no full node to give the transaction to over RPC. - * A node refused it and said why. + * A node refused it over RPC and said why, or every peer that + answered refused it and said why. content: application/json: schema: @@ -2039,16 +2082,8 @@ $ref: '#/components/schemas/Error' '500': description: | - The server could not find out whether the network took the - transaction. Post the same transaction again to ask again. - - * `server-timeout`: a node took the transaction and none announced - it within the time this server waits (30 seconds by default). - Most likely it was refused: Bitcoin Core does not say when it - refuses a transaction. - * `server-error`: no node could be reached; or a node closed the - connection on receiving the transaction, which a node does with - one it finds invalid. + `server-error`: this server has no peer to hand the transaction to, + or reached none. content: application/json: schema: diff --git a/test/Haskoin/Store/Database/MigrateSpec.hs b/test/Haskoin/Store/Database/MigrateSpec.hs --- a/test/Haskoin/Store/Database/MigrateSpec.hs +++ b/test/Haskoin/Store/Database/MigrateSpec.hs @@ -241,10 +241,11 @@ map (\td -> (td.block, td.timestamp)) <$> stored `shouldReturn` [(BlockRef 2 1, time)] wrongTimes db `shouldReturn` [] -- and when the block is reverted it goes back to the mempool - -- with that time, which every store has for it - reverted <- apply layeredRules db (Revert (headerHash (maybe (error "no block") (.header) best))) + -- with the time of the revert, which the timeout of the mempool + -- counts from + reverted <- apply layeredRules db (Revert (headerHash (maybe (error "no block") (.header) best)) 7000) isRight reverted.result `shouldBe` True - fmap (.timestamp) <$> M.getMempoolTx db (txHash tx) `shouldReturn` Just time + fmap (.timestamp) <$> M.getMempoolTx db (txHash tx) `shouldReturn` Just 7000 modifyMaxSuccess (const 20) $ it "is the time of its block, after any history" $ -- whatever a store saw in its mempool before, and through blocks @@ -345,7 +346,7 @@ -- a block that is reverted takes its spenders along, and a group -- with none left has no key best <- Q.getBestBlock db >>= maybe (fail "no best block") return - reverted <- apply layeredRules db (Revert best) + reverted <- apply layeredRules db (Revert best 0) isRight reverted.result `shouldBe` True keysNow `shouldReturn` [] Q.getChainSpenders db (txHash wide) `shouldReturn` IntMap.empty diff --git a/test/Haskoin/Store/Fleet/MemberSpec.hs b/test/Haskoin/Store/Fleet/MemberSpec.hs --- a/test/Haskoin/Store/Fleet/MemberSpec.hs +++ b/test/Haskoin/Store/Fleet/MemberSpec.hs @@ -74,7 +74,7 @@ memberForget m out.removed when (isRight out.result) $ case op of Mine _ _ -> best >>= noteBest m - Revert _ -> best >>= noteBest m + Revert _ _ -> best >>= noteBest m -- a store deletes what is too old, and the pool -- does the same by its own clock Delete _ -> void (poolWithdraw conn keys 32 (map encode out.removed)) @@ -153,7 +153,7 @@ memberForget bare out.removed when (isRight out.result) $ case op of Mine _ _ -> best >>= \b -> noteBest m b >> noteBest bare b - Revert _ -> best >>= \b -> noteBest m b >> noteBest bare b + Revert _ _ -> best >>= \b -> noteBest m b >> noteBest bare b Delete _ -> void (poolWithdraw conn keys 32 (map encode out.removed)) Pay _ _ -> return () if seed `mod` 5 == 0 diff --git a/test/Haskoin/Store/Fleet/RedisSpec.hs b/test/Haskoin/Store/Fleet/RedisSpec.hs --- a/test/Haskoin/Store/Fleet/RedisSpec.hs +++ b/test/Haskoin/Store/Fleet/RedisSpec.hs @@ -70,7 +70,7 @@ it "keeps the shared mempool as the rules say, step by step" $ \(conn, fresh) -> property $ \steps -> ioProperty $ do keys <- fresh - foldM_ (pooled conn keys) (P.empty, Nothing, 0) (steps :: [PoolStep]) + foldM_ (pooled conn keys) (P.empty, Nothing, 0, (Map.empty, Map.empty)) (steps :: [PoolStep]) it "turns away an offer that was checked against another tip" $ \(conn, fresh) -> do keys <- fresh fleetReport conn keys Nothing 60000 "a" [block 1] [] `shouldReturn` True @@ -82,7 +82,7 @@ -- the tip does not move to a block that the stores do not agree on fleetAdvance conn keys 4 Nothing (Just (block 1)) (block 2) (Just nothing) [] `shouldReturn` Raced fleetReport conn keys Nothing 60000 "a" [block 2, block 1] [block 1] `shouldReturn` True - let confirms = nothing {confirmed = [block 7], spent = [out 0 0]} + let confirms = nothing {confirmed = [block 7], spent = [out 0 0 <> block 7 <> encode (2 :: Word32)]} fleetAdvance conn keys 4 Nothing (Just (block 1)) (block 2) (Just confirms) [] `shouldReturn` MovedTo (block 2) poolSpends conn keys `shouldReturn` [] poolBody conn keys (block 7) `shouldReturn` Nothing @@ -102,7 +102,7 @@ -- a block confirms the third, which is not an event of the mempool, -- and the tip moves through two blocks fleetReport conn keys Nothing 60000 "a" [block 3, block 2, block 1] [block 1] `shouldReturn` True - let confirms = nothing {confirmed = [block 9], spent = [out 0 1]} + let confirms = nothing {confirmed = [block 9], spent = [out 0 1 <> block 9 <> encode (3 :: Word32)]} fleetAdvance conn keys 4 Nothing (Just (block 1)) (block 3) (Just confirms) [block 2, block 3] `shouldReturn` MovedTo (block 3) heard <- map snd <$> fleetEventsAfter conn keys start 10 @@ -239,9 +239,9 @@ fleetMove conn keys (Just now) seen `shouldReturn` expected same conn keys now model' return (model', now) - nothing = PoolChange {returned = [], gone = [], confirmed = [], spent = []} + nothing = PoolChange {returned = [], gone = [], confirmed = [], spent = [], height = Nothing, lost = []} -- carry a step of the pool out in Redis and in the model, and compare - pooled conn keys (model, tip, n) = \case + pooled conn keys (model, tip, n, kept) = \case Give t inputs replaced -> do -- a transaction spends from those of lower numbers only, as none -- can spend from one that spends from it @@ -255,30 +255,73 @@ got <- poolOffer conn keys 4 tip (txOf t (map fst outs)) (map snd outs) (map block replaced) sorted got `shouldBe` sorted expected samePool conn keys model' - return (model', tip, n) + return (model', tip, n, kept) Take ts -> do let model' = P.withdraw (map block ts) model left <- poolWithdraw conn keys 4 (map block ts) Set.fromList left `shouldBe` Map.keysSet model.spends `Set.difference` Map.keysSet model'.spends samePool conn keys model' - return (model', tip, n) + return (model', tip, n, kept) Go back dead done used -> do - -- one store, which reports a block that no step has had + -- one store, which reports a block that no step has had, 700 + -- blocks above the last, so that what was replaced is forgotten + -- three steps later let target = block (1000 + n) + height = 700 * (n + 1) returned' = [(block t, [out a i | (a, i) <- nubOrd ins, a < t]) | (t, ins) <- back] - change = P.Change returned' (map block dead) (map block done) [out a i | (a, i) <- used] + -- what spends each output in the blocks, one of the + -- transactions of the tests, so that it may come back later + labelled = [(out a i, block ((a * 7 + i * 3 + n) `mod` 12) <> encode height) | (a, i) <- used] + change = P.Change returned' (map block dead) (map block done) (map fst labelled) + -- the store names those of the abandoned blocks that it has as + -- replaced: here one of those that are gone, by a transaction + -- that the blocks may confirm now, later or never + lost = [(block t, block w, block w <> encode height) | t <- take 1 dead, let w = (t * 5 + n) `mod` 12] sent = PoolChange [txOf (number t) os | (t, os) <- returned'] change.gone change.confirmed - change.spent + [o <> w | (o, w) <- labelled] + (Just height) + [t <> w | (t, _, w) <- lost] fleetReport conn keys (Just 0) 10 "a" [target] (maybe [] pure tip) `shouldReturn` True fleetAdvance conn keys 4 (Just 0) tip target (Just sent) [] `shouldReturn` MovedTo target - let model' = P.advance maker change model + let (records, waiting) = kept + (model', replaced, waiting') = P.advanceReplacing maker change (`lookup` labelled) lost waiting model + -- what a transaction that comes back had replaced is forgotten + -- first, then the new, then what is 2016 blocks old + back' = Set.fromList (map fst returned') + unwon = Map.filter (\w -> not (Set.member (B.take 4 w) back')) records + records' = Map.filter fresh (foldl' (\m (t, w) -> Map.insert t w m) unwon replaced) + waiting'' = Map.filter (fresh . snd) waiting' + fresh w = height < 2016 || either (const False) (> height - 2016) (decode (B.drop 4 w)) samePool conn keys model' - return (model', Just target, n + 1) + sameReplaced conn keys records' waiting'' + return (model', Just target, n + 1, (records', waiting'')) maker = B.take 4 + -- what is kept of replaced transactions, with its two indices + sameReplaced conn keys expected waiting = do + let key k = keys.prefix <> k + list :: Redis.Redis (Either Redis.Reply a) -> IO a + list = fmap (either (error . show) id) . Redis.runRedis conn + waits <- list (Redis.hgetall (key "pool:lost")) + Map.fromList waits `shouldBe` Map.map snd waiting + forM_ (Map.toList waiting) $ \(t, (by, _)) -> + list (Redis.sismember (key ("pool:lostby:" <> by)) t) `shouldReturn` True + byWinner <- list (Redis.keys (key "pool:lostby:*")) + Set.fromList byWinner `shouldBe` Set.fromList [key ("pool:lostby:" <> by) | (by, _) <- Map.elems waiting] + lostAt <- list (Redis.zcard (key "pool:lostat")) + lostAt `shouldBe` fromIntegral (Map.size waiting) + kept <- list (Redis.hgetall (key "pool:rep")) + Map.fromList kept `shouldBe` expected + at <- list (Redis.zrangeWithscores (key "pool:repat") 0 (-1)) + let heightOf w = either (const (-1)) fromIntegral (decode (B.drop 4 w) :: Either String Word32) + Map.fromList at `shouldBe` Map.map heightOf expected + forM_ (Map.toList expected) $ \(t, w) -> + list (Redis.sismember (key ("pool:repby:" <> B.take 4 w)) t) `shouldReturn` True + bys <- list (Redis.keys (key "pool:repby:*")) + Set.fromList bys `shouldBe` Set.fromList [key ("pool:repby:" <> B.take 4 w) | w <- Map.elems expected] sorted = \case Conflict rivals -> Conflict (sort rivals) other -> other diff --git a/test/Haskoin/Store/Histories.hs b/test/Haskoin/Store/Histories.hs --- a/test/Haskoin/Store/Histories.hs +++ b/test/Haskoin/Store/Histories.hs @@ -180,7 +180,7 @@ data Rules = Rules { initBest :: Writer -> IO (), importBlock :: Writer -> Block -> BlockNode -> IO (BlockData, [TxData]), - revertBlock :: Writer -> BlockHash -> IO (), + revertBlock :: Writer -> UnixTime -> BlockHash -> IO (), newMempoolTx :: Writer -> Tx -> UnixTime -> IO Bool, deleteUnconfirmedTx :: Writer -> Bool -> TxHash -> IO () } @@ -191,7 +191,7 @@ Rules { initBest = Mixed.initBest, importBlock = Mixed.importBlock, - revertBlock = Mixed.revertBlock, + revertBlock = Mixed.revertBlockAt, newMempoolTx = Mixed.newMempoolTx, deleteUnconfirmedTx = Mixed.deleteUnconfirmedTx } @@ -239,8 +239,8 @@ Mine !Block !BlockNode | -- | a mempool transaction is deleted, with its descendants Delete !TxHash - | -- | the best block is reverted - Revert !BlockHash + | -- | the best block is reverted, at a time + Revert !BlockHash !UnixTime deriving (Show) -- | What an operation did: what the rules returned or why they refused, and @@ -260,7 +260,7 @@ -- that each layout keeps in a body Mine block node -> outcome . fmap (first fst) <$> run db (\w -> rules.importBlock w block node) Delete h -> outcome <$> run db (\w -> rules.deleteUnconfirmedTx w False h) - Revert h -> outcome <$> run db (\w -> rules.revertBlock w h) + Revert h time -> outcome <$> run db (\w -> rules.revertBlock w time h) where outcome :: (Show a) => Either ImportException (a, MempoolChanges) -> Outcome outcome (Left e) = Outcome {result = Left e, added = [], removed = []} @@ -275,7 +275,7 @@ | isLeft out.result -> noted block.txs | otherwise -> (noted block.txs) {chain = (block, node) : hist.chain} Delete _ -> hist - Revert _ + Revert _ _ | isLeft out.result -> hist | otherwise -> hist {chain = drop 1 hist.chain} where @@ -492,7 +492,7 @@ h : _ | even s -> h _ -> TxHash (sha256 (encode seed)) revert = return $ case hist.chain of - (b, _) : _ : _ -> Just (Revert (headerHash b.header)) + (b, _) : _ : _ -> Just (Revert (headerHash b.header) hist.clock) _ -> Nothing -- an earlier transaction, which may be confirmed, in the mempool, -- deleted, or missing what it spends diff --git a/test/Haskoin/Store/IntegrationSpec.hs b/test/Haskoin/Store/IntegrationSpec.hs --- a/test/Haskoin/Store/IntegrationSpec.hs +++ b/test/Haskoin/Store/IntegrationSpec.hs @@ -173,6 +173,9 @@ aroundAll (withEnvOf False kind ctx) $ describe (name kind <> " that does not whitelist the store") $ it "publishes what it verified, and keeps its node when sent what it cannot verify" strangerTest + aroundAll (withEnvAt True (Just (30 * 24 * 3600)) BitcoinCore ctx) $ + describe "Bitcoin Core with blocks of a month ago" $ + it "keeps what a reorganisation of an old block put back in the mempool" oldBlockTest aroundAll (withEnv BitcoinCore ctx) $ describe "Bitcoin Core" (chainSpec BitcoinCore) aroundAll (withEnv BitcoinCashNode ctx) $ @@ -203,8 +206,8 @@ it "evicts the least recently used xpubs" evictTest it "answers an error in JSON, whatever was asked for" errorFormatTest it "answers the Haskell client of haskoin-store-data" clientTest - it "publishes through a full node, and shows only what the node announced back" publishTest - it "publishes over the RPC of its node when given it, and through a peer when that fails" askTest + it "hands what it verified to its peers, and shows only what a node announced back" publishTest + it "publishes over the RPC of its node when given it, and through its peers when that fails" askTest when (kind == BitcoinCashNode) $ it "publishes transactions that make and spend tokens" tokenTest it "publishes spends of a multisig, signed the old way and with Schnorr signatures" multisigTest @@ -262,7 +265,12 @@ -- transactions seconds later, so the web servers wait longer for one they -- published, and it does not give its mempool when asked. withEnvOf :: Bool -> NodeKind -> Ctx -> (Env -> IO ()) -> IO () -withEnvOf whitelisted kind ctx go = do +withEnvOf whitelisted = withEnvAt whitelisted Nothing + +-- | The same, with the first blocks made a number of seconds in the past: +-- the node's clock is set back for them with @setmocktime@, and left so. +withEnvAt :: Bool -> Maybe Int -> NodeKind -> Ctx -> (Env -> IO ()) -> IO () +withEnvAt whitelisted ago kind ctx go = do image <- testImage withContainer (redisContainer image) $ \redis -> do redisPort <- hostPort redis 6379 @@ -279,6 +287,11 @@ p2p = p2pPort } waitRpc node + -- before the wallet is made: a wallet does not look at blocks older + -- than itself + forM_ ago $ \secs -> do + now <- round <$> getPOSIXTime + void $ rpc node "setmocktime" [Number (fromIntegral (now - secs :: Int))] ensureWallet node miner <- getNewAddress node -- enough mature coinbases for the wallet to fund every test without @@ -289,8 +302,7 @@ cfg = (storeConfig net ctx logger dir redisURL p2pPort False) {syncMempool = whitelisted} withStore cfg $ \store -> do listening $ \(cachedSock, cachedPort) -> listening $ \(plainSock, plainPort) -> do - let patient c = c {limits = c.limits {publishTimeout = 45}} :: WebConfig - web s = runWebSocket ((if whitelisted then id else patient) (webConfig logger s)) + let web s = runWebSocket (webConfig logger s) conn <- Redis.checkedConnect (either error id (Redis.parseConnectInfo redisURL)) cache <- maybe (fail "The store has no cache") return store.cache withAsync (web store cachedSock) $ \a1 -> @@ -376,8 +388,7 @@ maxLaggingBlocks = 100, maxPendingTxs = 10000, minPeers = 0, - -- a short wait, for the transactions that a node takes and says nothing of - limits = def {publishTimeout = 3}, + limits = def, version = "test", noMempool = False, stats = Nothing, @@ -1280,7 +1291,7 @@ -- | A transaction confirmed in a block that a reorganisation removes, and -- double-spent in the new chain, must disappear from the store and from the --- cache. +-- cache, and is answered 410 with the transaction that replaced it. -- -- Bitcoin Cash Node cannot mine a chosen transaction (@generateblock@), so -- the double spend is set up with coinbase maturity: transaction A spends a @@ -1314,6 +1325,13 @@ e <- expect <$> readIORef ref e.txids `shouldBe` [txB] checkXPub env x ref + -- asked for by its id, the payment that lost says what replaced it, from + -- the database and from the cache alike, where one that never was is 404 + forM_ [env.plain, env.cached] $ \url -> do + (code, v) <- getJSON url ("/transaction/" <> cs txA) + (code, textField "error" v, textField "replaced-by" v) `shouldBe` (410, Just "replaced", Just txB) + fst <$> getJSON url ("/transaction/" <> cs txA <> "/raw") `shouldReturn` 410 + fst <$> getJSON env.plain ("/transaction/" <> replicate 64 '1') `shouldReturn` 404 -- | A coinbase that may be spent in the next block and not before, and a -- way to spend it to an address. A spend in that block is dropped by the @@ -1373,9 +1391,35 @@ (field "block" v >>= field "mempool") `shouldSatisfy` isJust (_, raw) <- getJSON env.plain ("/transaction/" <> cs txA <> "/raw") tx <- maybe (fail "No raw transaction") (either fail return . decodeTxBody env.net . cs) (textField "result" raw) - publishTx env tx >>= \(c, r) -> (c, textField "txid" r) `shouldBe` (200, Just txA) + publishTx env tx >>= \(c, r) -> (c, textField "txid" r) `shouldBe` (202, Just txA) (txA `elem`) <$> rawMempool env.node `shouldReturn` True +-- | A payment confirmed in a block of a month ago that a reorganisation +-- reverts goes back to the mempool, and stays there while the node has +-- it. It went back with the time of its block, and the store deletes +-- mempool transactions older than its timeout of 14 days on every clock +-- tick, so it was gone in under a second. The node's clock is a month +-- back when the test starts ('withEnvAt'); the new blocks are made with +-- @generateblock@ and no transactions, so that the node keeps the payment. +oldBlockTest :: Env -> IO () +oldBlockTest env = do + to <- getNewAddress env.node + txA <- sendTo env.node to 100000 + waitFor "the payment in the store" ((== 200) . fst <$> getJSON env.plain ("/transaction/" <> cs txA)) + [blockX] <- mine env 1 + -- the real time from now on: the new blocks are of today + void $ rpc env.node "setmocktime" [Number 0] + void $ rpc env.node "invalidateblock" [String blockX] + (txA `elem`) <$> rawMempool env.node `shouldReturn` True + replicateM_ 2 $ rpc env.node "generateblock" [String env.miner, toJSON ([] :: [Text])] + waitSynced env + (txA `elem`) <$> rawMempool env.node `shouldReturn` True + -- longer than a few clock ticks + threadDelay 3000000 + (code, v) <- getJSON env.plain ("/transaction/" <> cs txA) + code `shouldBe` 200 + (field "block" v >>= field "mempool") `shouldSatisfy` isJust + ------------------------------------------------------------------------------- -- Cache ------------------------------------------------------------------------------- @@ -1825,24 +1869,22 @@ described `shouldSatisfy` C8.isInfixOf "servers:\n - url: './'\n" described `shouldNotSatisfy` C8.isInfixOf "api.haskoin.com" --- | Transactions posted to the store. A good one is handed to the node, --- which announces it back: the answer comes once the store has it, and --- posting it again sends nothing. What the store can tell is wrong is --- refused with the reason: an output it does not know or that is spent, --- and a signature of a key that does not verify. One that only a node can --- refuse, here for paying no fee, is not answered as published and never --- shows; after it the store still has its node, and publishes the next. +-- | Transactions posted to the store. A good one is handed to the node +-- and answered 202 at once; the store asks for it back, and has it a few +-- seconds later. Posted again, it is handed over again. What the store can +-- tell is wrong is refused with the reason: an output it does not know or +-- that is spent, and a signature of a key that does not verify. One that +-- only a node can refuse, here for paying no fee, is refused with the +-- node's reason on Bitcoin Cash, handed over on Bitcoin, and never shows; +-- after it the store still has its node, and publishes the next. publishTest :: Env -> IO () publishTest env = do first <- unsent env - let firstId = cs (txHashToHex (txHash first)) - publishTx env first >>= \(code, v) -> (code, textField "txid" v) `shouldBe` (200, Just (cs firstId)) - -- it is there for the request that follows - (seen, _) <- getJSON env.plain ("/transaction/" <> firstId) - seen `shouldBe` 200 + let firstId = txHashToHex (txHash first) + handedOver env first inNode <- rpc env.node "getrawmempool" [] - arr inNode `shouldSatisfy` elem (String (cs firstId)) - publishTx env first >>= \(code, _) -> code `shouldBe` 200 + arr inNode `shouldSatisfy` elem (String firstId) + publishTx env first >>= \(code, _) -> code `shouldBe` 202 -- an output that the store does not know let nowhere = OutPoint (TxHash (sha256 ("nowhere" :: C8.ByteString))) 0 orphan = first {inputs = [i {outpoint = nowhere} | i <- take 1 first.inputs], witness = []} :: Tx @@ -1858,19 +1900,18 @@ fmap (T.isInfixOf "does not verify") (textField "message" v) `shouldBe` Just True (unseen, _) <- getJSON env.plain ("/transaction/" <> cs (txHashToHex (txHash forged))) unseen `shouldBe` 404 - -- one that pays no fee, which only a node refuses + -- one that pays no fee, which only a node refuses: Bitcoin Cash Node + -- says why, Bitcoin Core takes it in silence and does not keep it free <- unsentFree env - (code, v) <- publishTx env free - case env.node.kind of - -- Bitcoin Cash Node says why + publishTx env free >>= \(code, v) -> case env.node.kind of BitcoinCashNode -> do code `shouldBe` 400 - fmap (T.isInfixOf "A node refused") (textField "message" v) `shouldBe` Just True - -- Bitcoin Core says nothing - BitcoinCore -> code `shouldBe` 500 + fmap (T.isInfixOf "refused") (textField "message" v) `shouldBe` Just True + BitcoinCore -> code `shouldBe` 202 + threadDelay 4000000 (unpaid, _) <- getJSON env.plain ("/transaction/" <> cs (txHashToHex (txHash free))) unpaid `shouldBe` 404 - publishTx env second >>= \(c, _) -> c `shouldBe` 200 + handedOver env second -- more than a transaction can be long: refused before it is read whole let most = 2 * (if env.net.segWit then 4000000 else 1000000) + 4096 publishBody env (C8.replicate (most + 1) '0') >>= \(c, _) -> c `shouldBe` 413 @@ -1879,7 +1920,20 @@ publishTx env (cheaper first) >>= \(c, e) -> do c `shouldBe` 400 fmap (T.isInfixOf "confirmed transaction has spent") (textField "message" e) `shouldBe` Just True + -- and the transaction in that block is answered 200: nothing to send + publishTx env first >>= \(code, v) -> (code, textField "txid" v) `shouldBe` (200, Just firstId) +-- | Post a good transaction: it is answered 202 with its id and a message, +-- and the store has it a few seconds later, when it has asked for it back. +handedOver :: Env -> Tx -> IO () +handedOver env tx = do + let txid = txHashToHex (txHash tx) + publishTx env tx >>= \(code, v) -> do + (code, textField "txid" v) `shouldBe` (202, Just txid) + fmap (T.isInfixOf "Handed over") (textField "message" v) `shouldBe` Just True + waitFor "the store to have the transaction" $ + (== 200) . fst <$> getJSON env.plain ("/transaction/" <> cs txid) + -- | A transaction of the node's wallet, signed and not sent. unsent :: Env -> IO Tx unsent env = do @@ -1950,42 +2004,115 @@ else tx {inputs = [i {script = encode (H.Script [H.opPushData script])} | i <- tx.inputs]} -- | A node that does not whitelist the store, which is what a node makes --- of any peer it did not choose. It announces a transaction on a timer, --- so the answer takes seconds, and is still that the store has it. +-- of any peer it did not choose. -- -- Such a node may close every connection of a peer that sends it a --- transaction it finds invalid, those the store syncs from too, and --- Bitcoin Cash Node does. So the store sends a peer only what it has --- verified: a transaction whose signature it cannot judge is refused, and --- one made to fail at the node, which used to cost the store its --- connections, never reaches the node. The store keeps its node, and --- publishes the next good transaction. +-- transaction it finds invalid, and Bitcoin Cash Node does. So the store +-- sends a peer only what it has verified, and refuses what was measured to +-- cost it its connections: a transaction whose signature it cannot judge, +-- a push in a longer form than it needs, and on Bitcoin Cash more tokens +-- out than in. None reaches the node; the store keeps the connection it +-- had to it, and publishes the next good transaction. strangerTest :: Env -> IO () strangerTest env = do + before <- peerIds unsent env >>= published -- a spend of a coin that a script locks: the store cannot tell a good -- one from one that the node would close its connections over forged <- unjudged env - publishTx env forged >>= \(code, v) -> do - code `shouldBe` 400 - fmap (T.isInfixOf "cannot verify") (textField "message" v) `shouldBe` Just True - threadDelay 1000000 - (length <$> getPeers env.store.peerMgr) >>= (`shouldSatisfy` (> 0)) + refused "cannot verify" forged + -- a signature pushed in a longer form than it needs, which Bitcoin Cash + -- Node closes every connection over, and Bitcoin Core does not relay + legacy <- legacySpend env + refused "longer form" (legacy {inputs = [i {script = longer i.script} | i <- legacy.inputs]} :: Tx) + -- more tokens out than in, which Bitcoin Cash Node closes them over too + when (env.kind == BitcoinCashNode) $ inflatedTokens env >>= refused "inputs do not hold" unsent env >>= published + -- the store kept the connection that it had to the node all along + threadDelay 1000000 + after <- peerIds + all (`elem` after) before `shouldBe` True -- the store follows the chain void $ mine env 1 where + peerIds = map (\p' -> numV (p' ! "id")) . arr <$> rpc env.node "getpeerinfo" [] + -- the node does not whitelist the store, and does not give back what + -- the store sent it when it has no other peer: the node has it published tx = do - publishTx env tx >>= \(code, _) -> code `shouldBe` 200 - (seen, _) <- getJSON env.plain ("/transaction/" <> cs (txHashToHex (txHash tx))) - seen `shouldBe` 200 + publishTx env tx >>= \(code, _) -> code `shouldBe` 202 + waitFor "the node to have the transaction" $ + elem (txHashToHex (txHash tx)) <$> rawMempool env.node + refused why tx = + publishTx env tx >>= \(code, v) -> + (code, fmap (T.isInfixOf why) (textField "message" v)) `shouldBe` (400, Just True) + -- every push with a byte of length, even where the opcode says it + longer bytes = case decode bytes of + Right (H.Script ops) -> encode (H.Script (map lengthened ops)) + Left _ -> bytes + lengthened = \case + H.OP_PUSHDATA d _ -> H.OP_PUSHDATA d H.OPDATA1 + o -> o +-- | A spend, signed by the wallet of the node, of a coin locked to the hash +-- of a key, whose input script holds the signature and the key. +legacySpend :: Env -> IO Tx +legacySpend env = do + a <- case env.kind of + BitcoinCore -> + rpc env.node "getnewaddress" [String "", String "legacy"] >>= \case + String t -> return t + other -> fail ("No address: " <> show other) + BitcoinCashNode -> getNewAddress env.node + _ <- sendTo env.node a 1000000 + void $ mine env 1 + coins <- arr <$> rpc env.node "listunspent" [Number 1, Number 9999999, toJSON [a]] + c <- case coins of + c : _ -> return c + [] -> fail "No coin of the address" + to <- getNewAddress env.node + let amount = case c ! "amount" of + Number n -> Number (n - 0.0001) + other -> other + rpc env.node "createrawtransaction" + [toJSON [object ["txid" .= (c ! "txid"), "vout" .= (c ! "vout")]], object [Key.fromText to .= amount]] + >>= signed env Nothing + +-- | Tokens of Bitcoin Cash made by the node, confirmed, and then a spend of +-- them, signed by the node, that gives more of them than it spends. +inflatedTokens :: Env -> IO Tx +inflatedTokens env = do + coins <- arr <$> rpc env.node "listunspent" [] + to <- getNewAddress env.node + c <- case [c | c <- coins, numV (c ! "vout") == 0] of + c : _ -> return c + [] -> fail "The wallet has no first output" + let amount less = case c ! "amount" of + Number n -> Number (n - less) + other -> other + holding tokens less = + object + [ Key.fromText to + .= object + [ "amount" .= amount less, + "tokenData" .= object ["category" .= (c ! "txid"), "amount" .= (tokens :: Text)] + ] + ] + spending txid = toJSON [object ["txid" .= txid, "vout" .= (0 :: Int)]] + genesis <- + rpc env.node "createrawtransaction" [spending (c ! "txid"), toJSON [holding "1000" 0.001]] + >>= signed env Nothing + void $ rpc env.node "sendrawtransaction" [String (encodeHex (encode genesis))] + void $ mine env 1 + rpc env.node "createrawtransaction" [spending (txHashToHex (txHash genesis)), toJSON [holding "2000" 0.002]] + >>= signed env Nothing + -- | A store that was given the RPC of its node publishes through it. A -- transaction that the node does not take is refused with the node's -- reason, on Bitcoin Core too, which says nothing to a peer. A good -- transaction whose signature the store cannot judge is published, where -- a store without the RPC refuses it. And when the RPC does not answer, --- what the store verified goes to a peer. +-- what the store verified goes to the peers. Each that is published is +-- answered 202. askTest :: Env -> IO () askTest env = withTestLogger $ \logger -> listening $ \(sock, port) -> listening $ \(deaf, deafPort) -> do let rpcURL = "http://test:test@" <> drop (length ("http://" :: String)) env.node.url @@ -2003,14 +2130,18 @@ waitFor "the server that has the RPC of the node" (up asking) waitFor "the server whose node does not answer" (up unanswered) unsentFree env >>= publishTx asking >>= refused "min relay fee not met" - unsent env >>= publishTx asking >>= \(code, _) -> code `shouldBe` 200 + unsent env >>= publishTx asking >>= \(code, v) -> do + code `shouldBe` 202 + fmap (T.isInfixOf "full node took") (textField "message" v) `shouldBe` Just True -- not judged by the store: over RPC only first <- unjudged env publishTx env first >>= refused "cannot verify" publishTx unanswered first >>= refused "cannot verify" - publishTx asking first >>= \(code, _) -> code `shouldBe` 200 - -- verified by the store: to a peer when the RPC does not answer - unsent env >>= publishTx unanswered >>= \(code, _) -> code `shouldBe` 200 + publishTx asking first >>= \(code, _) -> code `shouldBe` 202 + -- verified by the store: to the peers when the RPC does not answer + unsent env >>= publishTx unanswered >>= \(code, v) -> do + code `shouldBe` 202 + fmap (T.isInfixOf "Handed over") (textField "message" v) `shouldBe` Just True -- | Pay a script from the wallet of the node, and give the coin: where it -- is, and the output that holds it. @@ -2091,9 +2222,7 @@ published tx = do publishTx env (cheaper tx) >>= \(code, v) -> (code, fmap (T.isInfixOf "cannot verify") (textField "message" v)) `shouldBe` (400, Just True) - publishTx env tx >>= \(code, v) -> (code, v) `shouldSatisfy` ((== 200) . fst) - (seen, _) <- getJSON env.plain ("/transaction/" <> cs (txHashToHex (txHash tx))) - seen `shouldBe` 200 + handedOver env tx -- signed by the first two keys, the old way old locked hashType = do (coin, out) <- payScript env locked @@ -2178,7 +2307,8 @@ ] ] spending txid = toJSON [object ["txid" .= txid, "vout" .= (0 :: Int)]] - published tx = publishTx env tx >>= \(code, v) -> (code, v) `shouldSatisfy` ((== 200) . fst) + -- the spend needs the store to know what it spends + published = handedOver env genesis <- rpc env.node "createrawtransaction" [spending (coin ! "txid"), toJSON [holding 0.001]] >>= signed env Nothing @@ -2440,6 +2570,39 @@ waitFor "the health check of a member to pass" ((== 200) . fst <$> getJSON urlA "/health") (_, health) <- getJSON urlA "/health" ((health ! "redis") ! "ok") `shouldBe` Bool True + -- a payment that a reorganisation replaced, as in 'reorgTest': both + -- stores answer 410 alike, from what the pool kept as the tip moved + let y = newXPub env "fleet-replaced" DeriveNormal + (coinbaseSpend, cbValue) <- youngCoinbase env (newXPub env "fleet-coinbase" DeriveNormal) + txA <- coinbaseSpend (at env y [0, 0]) (cbValue - 100000) + [blockX] <- mine env 1 + waitStore env a + waitStore env b + atTip + header <- rpc env.node "getblockheader" [String blockX] + parent <- maybe (fail "No parent") return (textField "previousblockhash" header) + void $ rpc env.node "invalidateblock" [String parent] + other <- getNewAddress env.node + void $ generateTo env.node 1 other + txB <- coinbaseSpend (at env y [0, 1]) (cbValue - 200000) + void $ mine env 2 + waitStore env a + waitStore env b + atTip + let path = "/transaction/" <> T.unpack txA + answers = (,) <$> getJSON urlA path <*> getJSON urlB path + agreed <- tryAny . waitFor "both stores to answer that the payment was replaced" $ do + (fromA, fromB) <- answers + return (fromA == fromB && fst fromA == 410) + case agreed of + Right () -> return () + Left _ -> do + got <- answers + kept <- redisRun env (Redis.hgetall (cachePrefix env.net <> "pool:rep")) + local <- mapM (\st -> Q.getReplaced st.db (fromMaybe (error "txid") (hexToTxHash txA))) [a, b] + expectationFailure ("Not replaced alike: " <> show got <> "; pool: " <> show kept <> "; stores: " <> show local) + (_, gone) <- getJSON urlA ("/transaction/" <> T.unpack txA) + textField "replaced-by" gone `shouldBe` Just txB where -- Both members and their web servers log through the logger of the -- tests, each with its name in front of its lines. A logger of their diff --git a/test/Haskoin/Store/Logic/LayeredSpec.hs b/test/Haskoin/Store/Logic/LayeredSpec.hs --- a/test/Haskoin/Store/Logic/LayeredSpec.hs +++ b/test/Haskoin/Store/Logic/LayeredSpec.hs @@ -1,14 +1,15 @@ module Haskoin.Store.Logic.LayeredSpec (spec) where -import Control.Monad (foldM, forM_, void) +import Control.Monad (foldM, forM_, replicateM_, void) import Data.ByteString (ByteString) import Data.ByteString qualified as B -import Data.Either (isLeft) -import Data.List (sortOn) +import Data.Either (isLeft, isRight) +import Data.List (sort, sortOn) import Data.Maybe (isJust) import Data.Serialize (decode) import Haskoin ( Block (..), + BlockHeight, BlockHash, Ctx, Network, @@ -23,8 +24,8 @@ prepareContext, txHash, ) -import Haskoin.Store.Common (Start (..), StoreRead (..)) -import Haskoin.Store.Data (TxData (..), Unspent (..)) +import Haskoin.Store.Common (Replaced (..), Start (..), StoreRead (..), replacedKept) +import Haskoin.Store.Data (BlockData (..), TxData (..), Unspent (..)) import Haskoin.Store.Database.Mempool qualified as M import Haskoin.Store.Database.Migrate (upgradeDatabase) import Haskoin.Store.Database.Query qualified as Q @@ -75,7 +76,7 @@ mine txs db h = (h,) . Just <$> blockOn db txs pay tx _ h = return (h, Just (Pay tx h.clock)) revert _ h = return $ case h.chain of - (b, _) : _ -> (h, Just (Revert (headerHash b.header))) + (b, _) : _ -> (h, Just (Revert (headerHash b.header) h.clock)) [] -> (h, Nothing) -- the third store is upgraded with the spend in its mempool (outcomes, _) <- sameHistory ctx btcRegTest 2 [mine [twice], pay spend, mine [spend], revert, revert] @@ -94,6 +95,26 @@ (.result) <$> apply layeredRules db block `shouldReturn` Left Orphan everything db `shouldReturn` untouched + it "keep what a block replaced, and forget it when the block is reverted" $ + withSystemTempDirectory "haskoin-store-layered-" $ \dir -> + openLayered btcRegTest ctx dir $ \db -> do + (gone, height) <- replacedByBlock db + best <- Q.getBestBlock db >>= maybe (fail "no best block") return + isRight . (.result) <$> apply layeredRules db (Revert best 2000) `shouldReturn` True + mapM (Q.getReplaced db) gone `shouldReturn` [Nothing, Nothing] + Q.getReplacedAt db height `shouldReturn` [] + + it "forget what a block replaced 2016 blocks later" $ + withSystemTempDirectory "haskoin-store-layered-" $ \dir -> + openLayered btcRegTest ctx dir $ \db -> do + (gone, height) <- replacedByBlock db + let mineEmpty = blockOn db [] >>= apply layeredRules db + replicateM_ (fromIntegral replacedKept - 1) mineEmpty + all isJust <$> mapM (Q.getReplaced db) gone `shouldReturn` True + void mineEmpty + mapM (Q.getReplaced db) gone `shouldReturn` [Nothing, Nothing] + Q.getReplacedAt db height `shouldReturn` [] + it "leave the keys of a mempool transaction alone when a block confirms what it spends" $ withSystemTempDirectory "haskoin-store-layered-" $ \dir -> openLayered btcRegTest ctx dir $ \db -> do @@ -238,8 +259,10 @@ everything :: DatabaseReader -> IO Everything everything db = do best <- Q.getBestBlock db - blocks <- dump db (blockCF db.db) - heights <- dump db (heightCF db.db) + -- what is kept of replaced transactions is the layered layout's own, + -- and tested on its own + blocks <- filter (not . ("\x11" `B.isPrefixOf`) . fst) <$> dump db (blockCF db.db) + heights <- filter (not . ("\x12" `B.isPrefixOf`) . fst) <$> dump db (heightCF db.db) chain <- chainOf db area <- dump db (mempoolCF db.db) mempoolByAddress <- dump db (mempoolAddrCF db.db) @@ -262,3 +285,26 @@ decoded :: ByteString -> IO TxData decoded = either fail return . decode span' p xs = (filter p xs, filter (not . p) xs) + +-- | A payment and its child in the mempool, and a block whose transaction +-- spends what the payment spent: both are replaced. Gives their hashes and +-- the height of the block, after checking what is kept of them. +replacedByBlock :: DatabaseReader -> IO ([TxHash], BlockHeight) +replacedByBlock db = do + hist <- start layeredRules db + let paid = Tx 2 [TxIn (coinOf hist) "" maxBound] [TxOut 4000 (p2pkh 1)] [] 0 + child = Tx 2 [TxIn (OutPoint (txHash paid) 0) "" maxBound] [TxOut 3000 (p2pkh 2)] [] 0 + rival = Tx 2 [TxIn (coinOf hist) "" maxBound] [TxOut 4500 (p2pkh 3)] [] 0 + gone = map txHash [paid, child] + forM_ [paid, child] $ \tx -> + (.result) <$> apply layeredRules db (Pay tx 1000) `shouldReturn` Right "True" + block <- blockOn db [rival] + replaced <- apply layeredRules db block + sort replaced.removed `shouldBe` sort gone + best <- Q.getBestBlock db >>= maybe (fail "no best block") return + height <- maybe (fail "no block") (return . (.height)) =<< Q.getBlock db best + -- the payment, and its child, which spent what it paid + let what = Replaced {by = txHash rival, height = height} + mapM (Q.getReplaced db) gone `shouldReturn` [Just what, Just what] + Q.getReplacedAt db height `shouldReturn` sort gone + return (gone, height) diff --git a/test/Haskoin/Store/Web/PublishSpec.hs b/test/Haskoin/Store/Web/PublishSpec.hs --- a/test/Haskoin/Store/Web/PublishSpec.hs +++ b/test/Haskoin/Store/Web/PublishSpec.hs @@ -3,20 +3,17 @@ module Haskoin.Store.Web.PublishSpec (spec) where -import Control.Concurrent (forkIO, threadDelay) -import UnliftIO.Async (concurrently) import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVarIO) -import Control.Monad (replicateM_, void) +import Control.Monad (replicateM_) +import Data.ByteString (ByteString) import Data.ByteString qualified as B -import Data.Serialize (encode) -import Data.Time.Clock (UTCTime) +import Data.HashMap.Strict qualified as HashMap +import Data.IORef (modifyIORef', newIORef, readIORef) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Word (Word32, Word64) +import Data.Serialize (encode) +import Data.Word (Word32, Word64, Word8) import Haskoin hiding (Coin (..)) -import Haskoin.Store.Common (StoreEvent (..)) import Haskoin.Store.Web.Publish -import NQE (withPublisher) -import NQE qualified import Network.Socket (SockAddr (..), tupleToHostAddress) import Test.Hspec @@ -35,64 +32,86 @@ locktime = 0 } -limits :: Limits -limits = - Limits {wait = 0.3, handover = 1, tries = 2, capacity = 3, memory = 600} - -at :: Integer -> UTCTime -at = posixSecondsToUTCTime . fromInteger - -node :: Word32 -> SockAddr -node n = SockAddrInet 8333 (tupleToHostAddress (10, 0, 0, fromIntegral n)) - -- | A coin of a value that nothing is known of: not in a block, and with -- a script that the store cannot judge the spending of. held :: Word64 -> Coin held v = Coin {output = TxOut v "", mined = Nothing, coinbase = False} +-- | An input script that pushes a word, which 'rulesOf' reads. +saying :: ByteString -> ByteString +saying word = encode (Script [opPushData word]) + -- | The chain at block 1000. -- -- The signatures are judged by the scripts of the test: an input script --- of @forged@ is forged, one of @script@ cannot be told, and any other --- verifies. The real judge is tested in haskoin-core, and against nodes --- in the integration tests. +-- that pushes @forged@ is forged, one that pushes @script@ cannot be told, +-- and any other verifies. The real judge is tested in haskoin-core, and +-- against nodes in the integration tests. rulesOf :: Rules rulesOf = Rules {net = btc, inputs = \tx _ -> map verdict tx.inputs, height = 1000, medianTime = 1600000000} where verdict i - | i.script == "forged" = InputForged - | i.script == "script" = InputUndecided + | i.script == saying "forged" = InputForged + | i.script == saying "script" = InputUndecided | otherwise = InputVerified +-- | A peer, told apart by a number. +node :: Int -> SockAddr +node n = SockAddrInet 8333 (tupleToHostAddress (10, 0, 0, fromIntegral n)) + -- | A desk to publish at: every output is a coin of 1000, the store has no --- transaction, and the courier does what it is told for each node. It --- counts the times it was sent. -desk :: Ctx -> (SockAddr -> Tx -> IO Delivery) -> (Publishing -> IO Int -> IO a) -> IO a -desk ctx courier go = - withPublisher $ \events -> do - sent <- newTVarIO (0 :: Int) - here <- newTVarIO ([] :: [TxHash]) - outbox <- newTVarIO emptyOutbox - let p = - Publishing - { limits = limits, - outbox = outbox, - rules = return (rulesOf), - direct = \_ -> return Unavailable, - holds = \h -> (\hs -> if elem h hs then Pending else Absent) <$> readTVarIO here, - coin = \_ -> return (held 1000), - present = \h -> elem h <$> readTVarIO here, - events = events, - mempool = True, - nodes = return [node 1, node 2], - courier = \sa tx -> atomically (modifyTVar' sent (+ 1)) >> courier sa tx, - note = \_ _ -> return () - } - go p (readTVarIO sent) +-- transaction, there is no node to ask over RPC, and there are as many +-- peers as said, each of which does with a transaction what it is told. +-- It counts what each peer was handed, and the transactions asked for +-- after the answer. +desk :: Int -> (Int -> Tx -> Delivery) -> (Publishing -> IO [Int] -> IO [TxHash] -> IO a) -> IO a +desk n does go = do + sent <- newTVarIO (replicate n 0) + asked <- newIORef [] + let count k = atomically (modifyTVar' sent (\cs' -> [if j == k then c + 1 else c | (j, c) <- zip [0 ..] cs'])) + p = + Publishing + { rules = return rulesOf, + direct = \_ -> return Unavailable, + holds = \_ -> return Absent, + coin = \_ -> return (held 1000), + peers = return [node k | k <- [0 .. n - 1]], + courier = \sa tx -> case [k | k <- [0 .. n - 1], node k == sa] of + k : _ -> count k >> return (does k tx) + [] -> return NoConnection, + fetch = \h -> modifyIORef' asked (h :), + note = \_ _ -> return () + } + go p (readTVarIO sent) (reverse <$> readIORef asked) +-- | Every peer takes what it is handed. +taking :: Int -> Tx -> Delivery +taking _ _ = Took + +-- | The front of the script of an output that holds tokens: the category, +-- the flags, the commitment if there is one, and the amount if not zero. +withTokens :: ByteString -> Maybe (Word8, ByteString) -> Word64 -> ByteString +withTokens category nft amount = + B.concat + [ "\xef", + category, + B.singleton (nftFlags .|. (if amount > 0 then 0x10 else 0)), + maybe "" (\(_, c) -> if B.null c then "" else B.singleton (fromIntegral (B.length c)) <> c) nft, + if amount > 0 then compact amount else "", + "\x76\xa9\x14" <> B.replicate 20 7 <> "\x88\xac" + ] + where + nftFlags = case nft of + Nothing -> 0 + Just (capability, c) -> 0x20 .|. capability .|. (if B.null c then 0 else 0x40) + compact v + | v < 0xfd = B.singleton (fromIntegral v) + | otherwise = "\xfd" <> B.pack [fromIntegral v, fromIntegral (v `div` 256)] + a .|. b = a + b + spec :: Spec -spec = prepareContext $ \ctx -> do - let check = judge (rulesOf) +spec = do + let check = judge rulesOf describe "what the store can check" $ do let tx = spending [output 1, output 2] 1500 it "lets through a transaction that spends what is there" $ @@ -108,7 +127,6 @@ check (spending [nullOutPoint] 1) [Missing] `shouldBe` Left IsCoinbase check (spending [] 1) [] `shouldBe` Left NoInputs check (spending [output 1] 1) {outputs = []} [held 1] `shouldBe` Left NoOutputs - it "refuses a coinbase that is not a hundred blocks old" $ do let young h = Coin {output = TxOut 1000 "", mined = Just h, coinbase = True} one = spending [output 1] 900 @@ -133,122 +151,148 @@ check (paying 0 "\x6a\x04data") [held 1000] `shouldBe` Right Nothing it "refuses a forged signature, and names the input it cannot judge" $ do let signedBy items = (spending [output 1, output 2] 900) {inputs = zipWith input [1 ..] items} :: Tx - input n item = TxIn (output n) item maxBound + input n item = TxIn (output n) (saying item) maxBound check (signedBy ["good", "forged"]) [held 1000, held 1000] `shouldBe` Left (Forged 1) check (signedBy ["good", "script"]) [held 1000, held 1000] `shouldBe` Right (Just 1) check (signedBy ["good", "good"]) [held 1000, held 1000] `shouldBe` Right Nothing + it "refuses a version that nodes do not take: 1 to 3 on Bitcoin, 1 and 2 on Bitcoin Cash" $ do + let versioned v = (spending [output 1] 900) {version = v} :: Tx + cash = judge rulesOf {net = bch} + check (versioned 3) [held 1000] `shouldBe` Right Nothing + check (versioned 0) [held 1000] `shouldBe` Left (BadVersion 0) + check (versioned 4) [held 1000] `shouldBe` Left (BadVersion 4) + cash (versioned 2) [held 1000] `shouldBe` Right Nothing + cash (versioned 3) [held 1000] `shouldBe` Left (BadVersion 3) + it "refuses an input script that does more than push, or pushes in a longer form than it needs" $ do + let scripted ops = (spending [output 1] 900) {inputs = [TxIn (output 1) (encode (Script ops)) maxBound]} :: Tx + signature = B.replicate 71 1 + check (scripted [opPushData signature, opPushData (B.replicate 33 2)]) [held 1000] `shouldBe` Right Nothing + -- a push of 71 bytes takes one byte for its length, not two + check (scripted [OP_PUSHDATA signature OPDATA1]) [held 1000] `shouldBe` Left (NotMinimal 0) + -- the number 1 is OP_1, and the empty string OP_0 + check (scripted [OP_PUSHDATA "\x01" OPCODE]) [held 1000] `shouldBe` Left (NotMinimal 0) + check (scripted [OP_0, OP_1, OP_1NEGATE]) [held 1000] `shouldBe` Right Nothing + check (scripted [opPushData signature, OP_DUP]) [held 1000] `shouldBe` Left (NotPushOnly 0) + -- bytes that are not a script at all + check ((spending [output 1] 900) {inputs = [TxIn (output 1) "\x4c" maxBound]} :: Tx) [held 1000] + `shouldBe` Left (NotPushOnly 0) - describe "outbox" $ do - let k n = doubleSHA256 (encode (n :: Word32)) - come t n = enter limits (at t) (k n) - it "gives one request the transaction, and has the others join" $ do - let (first, box) = come 0 1 emptyOutbox - (second, _) = come 1 1 box - (first, second) `shouldBe` (Fresh, Joined) - it "remembers a refusal for a while, and not a success" $ do - let (_, box) = come 0 1 emptyOutbox - refused = settle (at 1) (k 1) (Refused "no") box - accepted = settle (at 1) (k 1) Accepted box - fst (come 2 1 refused) `shouldBe` Known (Refused "no") - fst (come 700 1 refused) `shouldBe` Fresh - fst (come 2 1 accepted) `shouldBe` Fresh - it "turns away what it has no room for" $ do - let (_, one) = come 0 1 emptyOutbox - (_, two) = come 0 2 one - (_, three) = come 0 3 two - fst (come 0 4 three) `shouldBe` Full - it "keeps taking others after nodes closed the courier on some" $ do - let (_, one) = come 0 1 emptyOutbox - (_, two) = come 0 2 (settle (at 1) (k 1) Dropped one) - box = settle (at 2) (k 2) Dropped two - fst (come 3 3 box) `shouldBe` Fresh - fst (come 3 1 box) `shouldBe` Known Dropped + describe "the tokens of Bitcoin Cash" $ do + let category = B.replicate 32 9 + -- a category made by this transaction: the id of what its first + -- input spends, whose index is 0 + newCategory = encode (OutPoint (TxHash (doubleSHA256 ("genesis" :: ByteString))) 0).hash + from n = OutPoint (output n).hash n + tx ins outs = (spending ins 0) {outputs = [TxOut 1000 s | s <- outs]} :: Tx + coin s = TxOut 1000 s + plain = "\x76\xa9\x14" <> B.replicate 20 7 <> "\x88\xac" + fungible c n = withTokens c Nothing n + nft c capability commitment = withTokens c (Just (capability, commitment)) 0 + it "lets tokens through as the inputs hold them" $ do + tokenRules (tx [from 1] [fungible category 400, fungible category 600]) [coin (fungible category 1000)] + `shouldBe` Right () + -- burnt: fewer out than in + tokenRules (tx [from 1] [fungible category 10]) [coin (fungible category 1000)] `shouldBe` Right () + tokenRules (tx [from 1] [plain]) [coin plain] `shouldBe` Right () + it "refuses more fungible tokens out than in" $ + tokenRules (tx [from 1, from 2] [fungible category 2000]) [coin (fungible category 1000), coin plain] + `shouldBe` Left (TokensUnbacked (concatMap (const "09") [1 .. 32 :: Int])) + it "makes tokens of a new category at will, from an input that spends an output 0" $ do + let genesisId = TxHash (doubleSHA256 ("genesis" :: ByteString)) + genesis = (tx [] [fungible newCategory 5000, nft newCategory 2 ""]) + {inputs = [TxIn (OutPoint genesisId 0) "" maxBound]} :: Tx + tokenRules genesis [coin plain] `shouldBe` Right () + -- the same category from an input that spends an output 1 is not new + let notNew = genesis {inputs = [TxIn (OutPoint genesisId 1) "" maxBound]} :: Tx + tokenRules notNew [coin plain] `shouldSatisfy` either (const True) (const False) + it "refuses tokens not written as tokens are" $ + tokenRules (tx [from 1] ["\xef\x01"]) [coin plain] `shouldBe` Left (BadTokens 0) + it "keeps non-fungible tokens to what the inputs allow" $ do + let keep = tx [from 1] [nft category 0 "a"] + -- the same immutable token passes on; another commitment does not + tokenRules keep [coin (nft category 0 "a")] `shouldBe` Right () + tokenRules keep [coin (nft category 0 "b")] `shouldSatisfy` either (const True) (const False) + -- a mutable one becomes any one token, not two + tokenRules keep [coin (nft category 1 "x")] `shouldBe` Right () + tokenRules (tx [from 1] [nft category 0 "a", nft category 0 "b"]) [coin (nft category 1 "x")] + `shouldSatisfy` either (const True) (const False) + -- a minting one makes any, and only a minting one makes one that mints + tokenRules (tx [from 1] [nft category 0 "a", nft category 2 "b"]) [coin (nft category 2 "")] + `shouldBe` Right () + tokenRules (tx [from 1] [nft category 2 "b"]) [coin (nft category 1 "")] + `shouldSatisfy` either (const True) (const False) describe "publishing" $ do let tx = spending [output 1] 900 - echo events = void . forkIO $ threadDelay 50000 >> NQE.publish (StoreMempoolNew (txHash tx)) events - it "answers when the transaction comes back, having sent it once" $ - desk ctx (\_ _ -> return Took) $ \p sent -> do - echo p.events - publish p tx `shouldReturn` Verdict Accepted - sent `shouldReturn` 1 + it "hands a transaction to every peer and answers at once, then asks for it" $ + desk 3 taking $ \p sent asked -> do + publish p tx `shouldReturn` ToPeers 3 + sent `shouldReturn` [1, 1, 1] + asked `shouldReturn` [txHash tx] + it "sends again, each time, what the store has unconfirmed" $ + desk 2 taking $ \p sent _ -> do + replicateM_ 2 $ publish p {holds = \_ -> return Pending} tx `shouldReturn` ToPeers 2 + sent `shouldReturn` [2, 2] it "sends nothing for what the store has in a block, or cannot be valid" $ - desk ctx (\_ _ -> return Took) $ \p sent -> do - publish p {holds = \_ -> return Confirmed} tx `shouldReturn` Verdict Accepted - publish p {coin = \_ -> return Missing} tx - `shouldReturn` Invalid (UnknownOutput (output 1)) - sent `shouldReturn` 0 - it "sends again what the store has unconfirmed, each time, and waits for no echo" $ - desk ctx (\_ _ -> return Took) $ \p sent -> do - let pending = p {holds = \_ -> return Pending} - replicateM_ 2 $ publish pending tx `shouldReturn` Verdict Accepted - sent `shouldReturn` 2 - -- checked first, like any other: a coinbase too young is not sent - publish pending {coin = \_ -> return (Coin {output = TxOut 1000 "", mined = Just 950, coinbase = True})} tx + desk 2 taking $ \p sent asked -> do + publish p {holds = \_ -> return Confirmed} tx `shouldReturn` InBlock + publish p {coin = \_ -> return Missing} tx `shouldReturn` Invalid (UnknownOutput (output 1)) + let young = Coin {output = TxOut 1000 "", mined = Just 950, coinbase = True} + publish p {holds = \_ -> return Pending, coin = \_ -> return young} tx `shouldReturn` Invalid (Immature (output 1)) - sent `shouldReturn` 2 - it "says why a node refuses what the store has unconfirmed" $ - desk ctx (\_ _ -> return (Rejected "missing inputs")) $ \p sent -> do - publish p {holds = \_ -> return Pending} tx `shouldReturn` Verdict (Refused "missing inputs") - sent `shouldReturn` 1 - it "gives the reason of a node, again without asking it again" $ - desk ctx (\_ _ -> return (Rejected "too cheap")) $ \p sent -> do - replicateM_ 2 $ - publish p tx `shouldReturn` Verdict (Refused "too cheap") - sent `shouldReturn` 1 - it "waits again, and sends nothing, for what a node took and did not announce" $ - desk ctx (\_ _ -> return Took) $ \p sent -> do - publish p tx `shouldReturn` Verdict Silent - echo p.events - publish p tx `shouldReturn` Verdict Accepted - sent `shouldReturn` 1 - it "goes to the next node when one cannot be reached, and tries anew when none can" $ do - desk ctx (\sa _ -> return (if sa == node 1 then NoConnection else Rejected "no")) $ \p sent -> do - publish p tx `shouldReturn` Verdict (Refused "no") - sent `shouldReturn` 2 - desk ctx (\_ _ -> return NoConnection) $ \p sent -> do - replicateM_ 2 $ publish p tx `shouldReturn` Verdict Unreachable - sent `shouldReturn` 4 - it "does not send again what a node closed the courier on, and goes on publishing the rest" $ - desk ctx (\_ t -> return (if t == tx then Closed else Rejected "no")) $ \p sent -> do - replicateM_ 2 $ publish p tx `shouldReturn` Verdict Dropped - publish p (spending [output 2] 900) `shouldReturn` Verdict (Refused "no") - sent `shouldReturn` 2 + sent `shouldReturn` [0, 0] + asked `shouldReturn` [] it "refuses a transaction larger than nodes relay" $ - desk ctx (\_ _ -> return Took) $ \p sent -> do + desk 1 taking $ \p sent _ -> do let long = (spending [output 1] 1) {outputs = [TxOut 1 (B.replicate 200000 1)]} :: Tx publish p long >>= \case Invalid (TooHeavy _) -> return () other -> expectationFailure (show other) - sent `shouldReturn` 0 + sent `shouldReturn` [0] it "gives it to a node over RPC where it can, and to no peer then" $ - desk ctx (\_ _ -> return Took) $ \p sent -> do - echo p.events - publish p {direct = \_ -> return Sent} tx `shouldReturn` Verdict Accepted - publish p {direct = \_ -> return (Declined "min relay fee not met")} (spending [output 2] 900) - `shouldReturn` Verdict (Refused "min relay fee not met") - sent `shouldReturn` 0 - it "sends to a peer only what it verified, and the rest over RPC only" $ - desk ctx (\_ _ -> return (Rejected "sent")) $ \p sent -> do - let unjudged = (spending [output 1] 900) {inputs = [TxIn (output 1) "script" maxBound]} :: Tx - -- no node to ask: it is not sent, and is not held against it - replicateM_ 2 $ publish p unjudged `shouldReturn` Verdict (Unverified 0) - sent `shouldReturn` 0 - -- a node that answers over RPC takes it - publish p {direct = \_ -> return (Declined "no")} unjudged `shouldReturn` Verdict (Refused "no") - -- one that was verified goes to a peer when RPC does not answer - publish p tx `shouldReturn` Verdict (Refused "sent") - sent `shouldReturn` 1 - it "sends a transaction once for two requests at the same time" $ - desk ctx (\_ _ -> threadDelay 100000 >> return (Rejected "no")) $ \p sent -> do - concurrently (publish p tx) (publish p tx) - `shouldReturn` (Verdict (Refused "no"), Verdict (Refused "no")) - sent `shouldReturn` 1 - it "does not take the bytes of one transaction for those of another with its id" $ do - -- same id, other witness: other bytes, so another slot - let other = tx {witness = [["x"]]} - txHash other `shouldBe` txHash tx - desk ctx (\_ t -> return (if t == tx then Took else Rejected "bad witness")) $ \p _ -> do - publish p other `shouldReturn` Verdict (Refused "bad witness") - echo p.events - publish p tx `shouldReturn` Verdict Accepted + desk 2 taking $ \p sent asked -> do + publish p {direct = \_ -> return Sent} tx `shouldReturn` ToNode + publish p {direct = \_ -> return (Declined "min relay fee not met")} tx + `shouldReturn` Refused "min relay fee not met" + sent `shouldReturn` [0, 0] + asked `shouldReturn` [txHash tx] + it "sends to the peers only what it verified, and the rest over RPC only" $ + desk 2 taking $ \p sent _ -> do + let unjudged = (spending [output 1] 900) {inputs = [TxIn (output 1) (saying "script") maxBound]} :: Tx + publish p unjudged `shouldReturn` Unverified 0 + sent `shouldReturn` [0, 0] + publish p {direct = \_ -> return Sent} unjudged `shouldReturn` ToNode + -- one that was verified goes to the peers when RPC does not answer + publish p tx `shouldReturn` ToPeers 2 + sent `shouldReturn` [1, 1] + it "says so when it has no peer, or reaches none" $ do + desk 0 taking $ \p _ asked -> do + publish p tx `shouldReturn` NoPeers + asked `shouldReturn` [] + desk 2 (\_ _ -> NoConnection) $ \p sent _ -> do + publish p tx `shouldReturn` NoPeers + sent `shouldReturn` [1, 1] + it "counts the peers that took it, and gives the reason when every one refused it" $ do + desk 3 (\k _ -> if k == 1 then Rejected "too cheap" else NoAnswer) $ \p _ _ -> + publish p tx `shouldReturn` ToPeers 2 + desk 2 (\_ _ -> Rejected "too cheap") $ \p _ asked -> do + publish p tx `shouldReturn` Refused "too cheap" + asked `shouldReturn` [] + desk 2 (\k _ -> if k == 0 then Closed else NoConnection) $ \p _ _ -> + publish p tx >>= (`shouldSatisfy` \case Refused _ -> True; _ -> False) + + describe "asking for it back" $ do + let at n = posixSecondsToUTCTime (fromInteger n) + h n = txHash (spending [output n] 1) + it "asks for what is due, and keeps it on the schedule for later" $ do + let m = HashMap.fromList [(h 1, (at 10, [25])), (h 2, (at 20, []))] + (ready, after) = due (at 10) m + ready `shouldBe` [h 1] + HashMap.lookup (h 1) after `shouldBe` Just (at 35, []) + HashMap.lookup (h 2) after `shouldBe` Just (at 20, []) + it "forgets a transaction after its last time" $ do + let (ready, after) = due (at 30) (HashMap.fromList [(h 1, (at 30, []))]) + ready `shouldBe` [h 1] + after `shouldBe` HashMap.empty + it "asks past the two minutes in which nodes give back what they took" $ + sum askAgain `shouldSatisfy` (> 120)