haskoin-store 1.12.1 → 1.13.0

raw patch · 29 files changed

+1565/−760 lines, 29 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +56/−0
• README.md +34/−39
• app/Main.hs +3/−10
• haskoin-store.cabal +1/−1
• src/Haskoin/Store/BlockStore.hs +2/−1
• src/Haskoin/Store/Common.hs +44/−2
• src/Haskoin/Store/Database/Query.hs +15/−1
• src/Haskoin/Store/Database/Query/Layered.hs +4/−2
• src/Haskoin/Store/Database/Query/Pooled.hs +13/−3
• src/Haskoin/Store/Database/Types.hs +47/−0
• src/Haskoin/Store/Database/Writer.hs +52/−2
• src/Haskoin/Store/Fleet/Member.hs +23/−4
• src/Haskoin/Store/Fleet/Pool.hs +48/−2
• src/Haskoin/Store/Fleet/Redis.hs +19/−6
• src/Haskoin/Store/Fleet/XPub.hs +2/−1
• src/Haskoin/Store/Fleet/lua/pool.lua +95/−16
• src/Haskoin/Store/Fleet/lua/read.lua +7/−0
• src/Haskoin/Store/Logic.hs +14/−2
• src/Haskoin/Store/Logic/Layered.hs +30/−13
• src/Haskoin/Store/Web.hs +110/−50
• src/Haskoin/Store/Web/Publish.hs +334/−325
• swagger.yaml +71/−36
• test/Haskoin/Store/Database/MigrateSpec.hs +5/−4
• test/Haskoin/Store/Fleet/MemberSpec.hs +2/−2
• test/Haskoin/Store/Fleet/RedisSpec.hs +55/−12
• test/Haskoin/Store/Histories.hs +7/−7
• test/Haskoin/Store/IntegrationSpec.hs +219/−56
• test/Haskoin/Store/Logic/LayeredSpec.hs +54/−8
• test/Haskoin/Store/Web/PublishSpec.hs +199/−155

@@ -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

@@ -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

@@ -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 $

@@ -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

@@ -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 "

@@ -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)

@@ -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)

@@ -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

@@ -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)]

@@ -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

@@ -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.

@@ -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)

@@ -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

@@ -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]

@@ -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     }  -------------------------------------------------------------------------------

@@ -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)

@@ -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

@@ -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)

@@ -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

@@ -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 -- 

@@ -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))

@@ -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": "<txid>", "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:

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)