haskoin-store 1.10.1 → 1.11.0

raw patch · 11 files changed

+1834/−69 lines, 11 filesdep ~haskoin-coredep ~haskoin-store-dataPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskoin-core, haskoin-store-data

API changes (from Hackage documentation)

Files

• CHANGELOG.md +74/−0
• README.md +55/−3
• app/Main.hs +19/−0
• haskoin-store.cabal +15/−13
• integration/Haskoin/Store/Integration/Node.hs +11/−0
• src/Haskoin/Store/Manager.hs +7/−2
• src/Haskoin/Store/Web.hs +192/−28
• src/Haskoin/Store/Web/Publish.hs +764/−0
• swagger.yaml +52/−16
• test/Haskoin/Store/IntegrationSpec.hs +404/−7
• test/Haskoin/Store/Web/PublishSpec.hs +241/−0

@@ -6,6 +6,80 @@  ## [Unreleased] +## [1.11.0] - 2026-11-12++`POST /transactions` is done another way, and now says what came of the+transaction. `docs/publishing.md` has the design and the measurements.++### Changed+- **A 200 means that a full node accepted the transaction and that the+  server has it.** It used to mean that the transaction was sent, and came+  at once whatever happened. The request now waits for a node to announce+  the transaction back, for `--publish-timeout` (`PUBLISH_TIMEOUT`)+  seconds at most, 30 by default. With a node that whitelists the store+  that takes milliseconds.+- The transaction is handed to one node, on a connection made for it. It+  used to go to half the peers, on the connections the store syncs from.+- The transaction comes into the mempool when a node announces it on a+  connection that never sent it. The store used to ask the peers it had+  sent it to, once, five seconds later.+- The same transaction posted again is sent once, and one that the store+  has is not sent at all.++### Added+- The store refuses, with 400 and the reason, a transaction that it can+  tell no node will take:+  - one that spends an output it does not know, one that a confirmed+    transaction has spent, or a coinbase less than a hundred blocks old;+  - one whose outputs are worth more than its inputs, or that is a+    coinbase;+  - one whose lock time has not passed;+  - one larger than nodes relay, or with an output that is dust;+  - **one with a forged signature**, for coins locked to one key: key+    hash, key, witness key hash plain or nested, and Taproot by its key;+    on Bitcoin Cash with ECDSA and Schnorr signatures, and for coins that+    hold tokens. This is `judgeInputs` of haskoin-core 1.6.2, which also+    verifies multisig: with ECDSA signatures on both networks, with+    Schnorr signatures on Bitcoin Cash, and the multisig of Taproot.+- `--node-rpc` (`NODE_RPC`): the JSON-RPC URL of a full node. The store+  publishes through it (`sendrawtransaction`): the node checks+  everything, says why it refuses, which Bitcoin Core does not tell a+  peer, and does not close the store's connections over what it refuses.+  When the node does not answer, the transaction goes to a peer.+- **A peer is sent only what the store verified.** A transaction with an+  input that the store cannot verify, a script that is not a key or a+  multisig, is refused with 400 unless the store can send it over RPC. A+  peer that finds a transaction invalid may close every connection of+  the store, so sending on what it could not judge let anyone cut the+  store off from its peers.+- The reason of a node that refuses a transaction and says why, as Bitcoin+  Cash Node does, is the message of the 400.+- 500 when no node could be reached, when a node closed the connection on+  receiving the transaction, and when no node announced it in time. The+  reference always listed these errors; the code gave none of them.+- A transaction that a node refused, closed the connection on, or did not+  announce is remembered for ten minutes and not sent again. Other+  transactions are published as before.+- The body of `POST /transactions` is read up to the length of the longest+  transaction of the network in hexadecimal, and a longer one is answered+  413. The server used to read a body of any size into memory.+- `Store` has `connect`, the function that opens a connection to a node.+- The integration tests run a store against a Bitcoin Core and a Bitcoin+  Cash Node that do not whitelist it.++### Fixed+- **A published transaction was often not seen until a block confirmed+  it.** Bitcoin Core does not give a transaction back on the connection+  that sent it until its timer for announcements has run, five seconds on+  average: the one request the store made at five seconds got `notfound`+  three times in four against Bitcoin Core 32.1. A store whose only node+  did not whitelist it then never took the transaction in.+- **One request could cut a store off from half its peers.** A node that+  finds a transaction invalid may close every connection from the address+  that sent it, and Bitcoin Cash Node 29.2 does. A forged transaction went+  to half the peers on the connections the store syncs from.+- With no peer connected the answer was 200 and nothing was sent.+ ## [1.10.1] - 2026-11-12  ### Changed

@@ -227,10 +227,15 @@ curl -X POST --data-binary @tx.hex localhost:3000/transactions ``` -The body is the signed transaction in hex. The store sends it to its peers and-returns the transaction id. It appears in the mempool, and in the wallet's-history, as soon as a peer relays it back.+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. +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 sends nothing twice.+[Publishing](#publishing) has the rest.+ ### 6. Stay up to date without polling  ```sh@@ -338,6 +343,8 @@ | `--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 | | `--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 |@@ -507,6 +514,10 @@   as a form (`application/x-www-form-urlencoded`), so that it does not   have to fit in a URL. `/transactions` does not: `POST` there publishes   a transaction.+- **A transaction to publish has a largest size**: the body of+  `POST /transactions` may be as long as the longest transaction of the+  network in hexadecimal, 8 MB with SegWit and 2 MB on Bitcoin Cash. More+  is answered 413 without being read whole. - **A 503 says when to try again**, in `Retry-After`. - **HTTPS is optional and off by default.** With `--tls-cert` and   `--tls-key` the server speaks HTTPS on its port, and nothing else. A@@ -547,6 +558,46 @@ - The **web server** answers from RocksDB, and from Redis for what is   cached there. +### Publishing++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.++- **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.+- **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.+- **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.+- **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.++`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.+ ### The database  The chain and the mempool are kept apart.@@ -675,6 +726,7 @@ | `Haskoin.Store.Cache` | The Redis cache of a server alone | | `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.Publish` | Publishing a transaction through a full node |  The rules and queries of version 20 (`Haskoin.Store.Logic`, `Haskoin.Store.Database.Query`) stay in the library as a reference. The

@@ -129,6 +129,7 @@     noXPub :: !Bool,     healthCheckInterval :: !Int,     accessLog :: !Bool,+    nodeRpc :: !String,     tlsCert :: !String,     tlsKey :: !String,     bloom :: !Bool,@@ -224,6 +225,8 @@     env "HEALTH_CHECK_INTERVAL" 1 readMaybe   accessLog <-     env "ACCESS_LOG" False parseBool+  nodeRpc <-+    env "NODE_RPC" "" pure   bloom <-     env "BLOOM" True parseBool   noWeb <-@@ -269,6 +272,8 @@         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.@@ -437,6 +442,13 @@           <> 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 $@@ -599,6 +611,12 @@     flag c.accessLog True $       long "access-log"         <> helpEnv "ACCESS_LOG" "Log every request, with the address of the client and the time it took"+  nodeRpc <-+    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"+        <> value c.nodeRpc   tlsCert <-     strOption $       metavar "FILE"@@ -766,6 +784,7 @@             noBlockchainInfo = cfg.noBlockchainInfo,             healthCheckInterval = cfg.healthCheckInterval,             accessLog = cfg.accessLog,+            nodeRpc = if null cfg.nodeRpc then Nothing else Just cfg.nodeRpc,             tls = case (cfg.tlsCert, cfg.tlsKey) of               ("", "") -> Nothing               ("", _) -> error "--tls-key needs --tls-cert"

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           haskoin-store-version:        1.10.1+version:        1.11.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@@ -78,6 +78,7 @@       Haskoin.Store.Web       Haskoin.Store.Web.Docs       Haskoin.Store.Web.Events+      Haskoin.Store.Web.Publish       Haskoin.Store.Web.Router   other-modules:       Paths_haskoin_store@@ -107,9 +108,9 @@     , file-embed >=0.0.16.0 && <0.1     , hashable >=1.5.1.0 && <1.6     , hashtables >=1.4.2 && <1.5-    , haskoin-core >=1.6.1 && <1.7+    , haskoin-core >=1.6.2 && <1.7     , haskoin-node >=2.5.1 && <2.6-    , haskoin-store-data ==2.0.*+    , haskoin-store-data >=2.0.1 && <2.1     , hedis >=0.16.4 && <0.17     , http-types >=0.12.6 && <0.13     , lens >=5.3.6 && <5.4@@ -172,9 +173,9 @@     , file-embed >=0.0.16.0 && <0.1     , hashable >=1.5.1.0 && <1.6     , hashtables >=1.4.2 && <1.5-    , haskoin-core >=1.6.1 && <1.7+    , haskoin-core >=1.6.2 && <1.7     , haskoin-node >=2.5.1 && <2.6-    , haskoin-store-data ==2.0.*+    , haskoin-store-data >=2.0.1 && <2.1     , hedis >=0.16.4 && <0.17     , http-types >=0.12.6 && <0.13     , lens >=5.3.6 && <5.4@@ -235,10 +236,10 @@     , filepath >=1.5.5.0 && <1.6     , hashable >=1.5.1.0 && <1.6     , hashtables >=1.4.2 && <1.5-    , haskoin-core >=1.6.1 && <1.7+    , haskoin-core >=1.6.2 && <1.7     , haskoin-node >=2.5.1 && <2.6     , haskoin-store-    , haskoin-store-data ==2.0.*+    , haskoin-store-data >=2.0.1 && <2.1     , hedis >=0.16.4 && <0.17     , http-types >=0.12.6 && <0.13     , lens >=5.3.6 && <5.4@@ -292,6 +293,7 @@       Haskoin.Store.OutageSpec       Haskoin.Store.TestBlocks       Haskoin.Store.Web.EventsSpec+      Haskoin.Store.Web.PublishSpec       Haskoin.Store.Web.RouterSpec       Haskoin.Store.WebSpec       Haskoin.StoreSpec@@ -325,10 +327,10 @@     , file-embed >=0.0.16.0 && <0.1     , hashable >=1.5.1.0 && <1.6     , hashtables >=1.4.2 && <1.5-    , haskoin-core >=1.6.1 && <1.7+    , haskoin-core >=1.6.2 && <1.7     , haskoin-node >=2.5.1 && <2.6     , haskoin-store-    , haskoin-store-data ==2.0.*+    , haskoin-store-data >=2.0.1 && <2.1     , hedis >=0.16.4 && <0.17     , hspec >=2.11.18 && <2.12     , http-types >=0.12.6 && <0.13@@ -392,10 +394,10 @@     , file-embed >=0.0.16.0 && <0.1     , hashable >=1.5.1.0 && <1.6     , hashtables >=1.4.2 && <1.5-    , haskoin-core >=1.6.1 && <1.7+    , haskoin-core >=1.6.2 && <1.7     , haskoin-node >=2.5.1 && <2.6     , haskoin-store-    , haskoin-store-data ==2.0.*+    , haskoin-store-data >=2.0.1 && <2.1     , hedis >=0.16.4 && <0.17     , http-types >=0.12.6 && <0.13     , lens >=5.3.6 && <5.4@@ -456,10 +458,10 @@     , file-embed >=0.0.16.0 && <0.1     , hashable >=1.5.1.0 && <1.6     , hashtables >=1.4.2 && <1.5-    , haskoin-core >=1.6.1 && <1.7+    , haskoin-core >=1.6.2 && <1.7     , haskoin-node >=2.5.1 && <2.6     , haskoin-store-    , haskoin-store-data ==2.0.*+    , haskoin-store-data >=2.0.1 && <2.1     , hedis >=0.16.4 && <0.17     , http-types >=0.12.6 && <0.13     , integration

@@ -23,6 +23,7 @@   ( NodeKind (..),     Node (..),     nodeContainer,+    strangerContainer,     nodeNetwork,     RpcError (..),     rpc,@@ -123,6 +124,16 @@             BitcoinCore -> [],       ports = [18443, 18444]     }++-- | The same node without the whitelist: it treats the store as it treats+-- any peer that connected to it. It announces transactions on its timer+-- and not at once, does not answer a request for its mempool, and may+-- close the connections of a peer that sends it an invalid transaction.+strangerContainer :: NodeKind -> String -> ContainerSpec+strangerContainer kind image =+  spec {name = spec.name <> "-stranger", command = filter (/= "-whitelist=0.0.0.0/0") spec.command}+  where+    spec = nodeContainer kind image  -- | Error returned by a node. data RpcError = RpcError !Text !Value

@@ -142,7 +142,11 @@     -- | network constants     net :: !Network,     -- | secp256k1 context-    ctx :: !Ctx+    ctx :: !Ctx,+    -- | how the store opens a connection to a node, for those it makes+    -- besides the ones of the peer manager+    -- ("Haskoin.Store.Web.Publish")+    connect :: !(SockAddr -> WithConnection)   }  -- | Configuration for a 'Store'.@@ -251,7 +255,8 @@                           events = events,                           pub = pub,                           net = cfg.net,-                          ctx = cfg.ctx+                          ctx = cfg.ctx,+                          connect = cfg.connect                         }  -- | The store as a member of a fleet, if the configuration says that it is

@@ -97,7 +97,7 @@     (.|),   ) import Control.Applicative ((<|>))-import Control.Lens ((.~), (^.))+import Control.Lens ((&), (.~), (?~), (^.)) import Control.Monad   ( filterM,     forM_,@@ -114,7 +114,9 @@   ( Encoding,     ToJSON (..),     Value,+    (.=),   )+import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson qualified as A import Data.Aeson.Encode.Pretty   ( Config (..),@@ -140,7 +142,10 @@ import Data.HashMap.Strict qualified as HashMap import Data.HashSet (HashSet) import Data.HashSet qualified as HashSet+import Data.Foldable qualified import Data.Int (Int64)+import Data.List qualified+import Data.Maybe qualified import Data.List (nub) import Data.Maybe   ( catMaybes,@@ -177,11 +182,11 @@     chainGetAncestor,     chainGetBest,     getPeers,+    logAt,     logDebug,     logError,     logInfo,     logWarn,-    sendMessage,     withSource,   ) import Haskoin.Script@@ -215,6 +220,7 @@ import Haskoin.Store.Manager import Haskoin.Store.Web.Docs (swaggerPage, swaggerYaml) import Haskoin.Store.Web.Events+import Haskoin.Store.Web.Publish qualified as Publish import Haskoin.Store.Web.Router hiding (header) import Haskoin.Store.WebCommon import Haskoin.Transaction@@ -247,12 +253,15 @@   ( Application,     Middleware,     Request (..),+    RequestBodyLength (..),     Response,+    getRequestBodyChunk,     mapResponseHeaders,     modifyResponse,     responseLBS,     responseStatus,     responseStream,+    setRequestBodyChunks,   ) import Network.Wai.Handler.Warp   ( defaultSettings,@@ -289,7 +298,6 @@ import Text.Read (readMaybe) import UnliftIO   ( TVar,-    async,     atomically,     bracket,     bracket_,@@ -299,6 +307,7 @@     fromException,     handleAny,     link,+    atomicModifyIORef',     newIORef,     newTQueueIO,     newTVarIO,@@ -312,6 +321,7 @@     throwIO,     timeout,     try,+    tryAny,     withAsync,     writeIORef,     writeTQueue,@@ -340,13 +350,17 @@     blockTimeout :: !Word64,     -- | seconds that a request may take before the log has a warning     -- about it ('logIt')-    slowRequest :: !Word32+    slowRequest :: !Word32,+    -- | seconds that @POST \/transactions@ waits for a node to announce+    -- the transaction back ("Haskoin.Store.Web.Publish")+    publishTimeout :: !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, and a warning for requests of five seconds.+-- block timeout of four hours, a warning for requests of five seconds, and+-- thirty seconds for a published transaction to come back. instance Default WebLimits where   def =     WebLimits@@ -358,7 +372,8 @@         xpubGapInit = 20,         txTimeout = 3600 `div` 2,         blockTimeout = 4 * 3600,-        slowRequest = 5+        slowRequest = 5,+        publishTimeout = 30       }  -- | Configuration of the web server.@@ -400,6 +415,10 @@     healthCheckInterval :: !Int,     -- | log every request, at the level of information ('logIt')     accessLog :: !Bool,+    -- | URL of the JSON-RPC interface of a full node, with its user and+    -- password, to publish transactions through ('sendNode'); 'Nothing'+    -- to publish through peers only+    nodeRpc :: !(Maybe String),     -- | a certificate and its private key, in files in PEM format, to     -- serve HTTPS instead of HTTP; 'Nothing' for HTTP, which is the     -- default@@ -429,7 +448,10 @@     -- for a store without a cache     cacheUp :: !(TVar Bool),     -- | the events that the clients of @\/events@ read ('feedEvents')-    eventLog :: !EventLog+    eventLog :: !EventLog,+    -- | the transactions being published, and those that failed not long+    -- ago ("Haskoin.Store.Web.Publish")+    outbox :: !(TVar Publish.Outbox)   }  -- | StatsD metrics of the web server: a timing for each kind of request,@@ -663,6 +685,7 @@   forM_ config.store.fleet $ \member -> atomically (writeTVar member.healthy (isOK first))   cacheUp <- cacheCheck >>= newTVarIO   eventLog <- newEventLog+  outbox <- newTVarIO Publish.emptyOutbox   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))@@ -739,7 +762,7 @@       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 $ app+          serve . webSocketEvents st . logged . anyOrigin . preflight . autohead . compressed . cappedBody st $ app   where     priceUpdater session =       unless config.noBlockchainInfo@@ -934,6 +957,40 @@           | net == bch = Just "bch"           | otherwise = Nothing +-- | Read no more of the body of a transaction to publish than a+-- transaction can be long: twice 'Publish.maxTxSize' in hexadecimal, and+-- some room for white space. More is answered 413, by its length when the+-- client gave it, and else as soon as that much was read.+--+-- The router reads the body whole before it knows what to do with it.+-- Without this, anyone could have the server hold a body of any size.+-- Other requests with a body are forms of parameters, and are not capped+-- here.+cappedBody :: WebState -> Middleware+cappedBody st app request respond+  | requestMethod request == methodPost,+    filter (not . T.null) (pathInfo request) == ["transactions"] =+      case requestBodyLength request of+        KnownLength n | n > fromIntegral most -> refuse+        _ -> do+          left <- newIORef most+          let chunk = do+                bytes <- getRequestBodyChunk request+                now <- atomicModifyIORef' left (\l -> let l' = l - C.length bytes in (l', l'))+                when (now < 0) (throwIO RequestTooLarge)+                return bytes+          app (setRequestBodyChunks chunk request) respond `catch` \case+            RequestTooLarge -> refuse+            e -> throwIO e+  | otherwise = app request respond+  where+    most = maxPublishBody st.config.store.net+    refuse = errorResponse st RequestTooLarge >>= respond++-- | The most bytes of the body of @POST \/transactions@.+maxPublishBody :: Network -> Int+maxPublishBody net = 2 * Publish.maxTxSize net + 4096+ -- | Stop handling the request, and answer with an error ('guarded'). raise :: WebState -> Except -> IO a raise _ = throwIO@@ -1499,29 +1556,136 @@  -- POST Transaction -- --- | Handler for @POST \/transactions@: broadcast a transaction to half of the peers and return its hash.+-- | 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"). 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 handlePostTx st (PostTx tx) =-  withMetrics st (.txPost) $ do-    let cfg = st.config-    (publishTx cfg tx)-    return (TxId (txHash tx))+  withMetrics st (.txPost) $+    Publish.publish (publishing st) tx >>= \case+      Publish.Verdict Publish.Accepted -> return (TxId (txHash tx))+      Publish.Invalid why -> raise st (UserError (show why))+      Publish.Verdict (Publish.Refused why) ->+        raise st (UserError ("A node refused the transaction: " <> T.unpack why))+      Publish.Verdict (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 --- | Send transaction to all connected peers.-publishTx ::-  WebConfig ->-  Tx ->-  IO ()-publishTx cfg tx = do-  ps <- getPeers cfg.store.peerMgr-  let c = max 1 (length ps `div` 2)-  forM_ (take c ps) $ \p -> do-    sendMessage (MTx tx) p.mailbox-    void . async $ do-      threadDelay (5 * 1000 * 1000)-      let v = if cfg.store.net.segWit then InvWitnessTx else InvTx-          g = MGetData (GetData [InvVector v (txHash tx).get])-      sendMessage g p.mailbox+-- | 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+-- the last eleven blocks.+chainRules :: WebState -> IO Publish.Rules+chainRules st = do+  best <- st.query.getBestBlock >>= maybe (return Nothing) st.query.getBlock+  times <- maybe (return []) (back (11 :: Int)) best+  return+    Publish.Rules+      { net = own.net,+        inputs = \tx -> judgeInputs own.net own.ctx tx . map Just,+        height = maybe 0 (.height) best,+        medianTime = case Data.List.sort times of+          [] -> 0+          sorted -> fromIntegral (sorted !! (length sorted `div` 2))+      }+  where+    own = st.config.store+    back n b+      | n <= 1 = return [b.header.timestamp]+      | otherwise =+          (b.header.timestamp :) <$> (st.query.getBlock b.header.prev >>= maybe (return []) (back (n - 1)))++-- | Give a transaction to a full node over its JSON-RPC interface+-- (@sendrawtransaction@).+--+-- The node runs every script and holds the transaction to its own rules+-- and its own mempool, says why it refuses, and does not close the+-- connections of the store over what it refuses, as it may over a+-- transaction that a peer sends it. A transaction that the node takes+-- comes back to the store as any other: the node announces it on the+-- connection that the store syncs from.+--+-- 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 that the node has already was sent.+sendNode :: WebState -> String -> Tx -> IO Publish.Direct+sendNode st url tx =+  tryAny (Wreq.Session.postWith opts st.session url body) >>= \case+    Left e -> unheard (cs (show e))+    Right r -> case A.decode (r ^. Wreq.responseBody) >>= answer of+      Nothing -> unheard ("HTTP " <> cs (show (r ^. Wreq.responseStatus . Wreq.statusCode)))+      Just Nothing -> return Publish.Sent+      Just (Just why)+        | "already" `T.isInfixOf` why -> return Publish.Sent+        | otherwise -> return (Publish.Declined why)+  where+    opts = Wreq.defaults & Wreq.checkResponse ?~ (\_ _ -> return ())+    body =+      A.object+        [ "jsonrpc" .= ("1.0" :: Text),+          "id" .= ("haskoin-store" :: Text),+          "method" .= ("sendrawtransaction" :: Text),+          "params" .= [encodeHex (runPutS (serialize tx))]+        ]+    -- the error of the answer if it has one, nothing if it has a result+    answer v = do+      A.Object top <- Just v+      case KeyMap.lookup "error" top of+        Just (A.Object e) | Just (A.String why) <- KeyMap.lookup "message" e -> Just (Just why)+        Just A.Null | KeyMap.member "result" top -> Just Nothing+        Nothing | KeyMap.member "result" top -> Just Nothing+        _ -> Nothing+    unheard why = do+      logWarn+        (withSource "Publish" st.config.logger)+        ("The node did not take a transaction over RPC, which goes to a peer if it is verified: " <> why)+      return Publish.Unavailable++-- | 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.+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,+      direct = maybe (\_ -> return Publish.Unavailable) (sendNode st) st.config.nodeRpc,+      has = fmap (maybe False (not . (.deleted))) . 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,+      courier =+        Publish.deliver+          Publish.Courier+            { net = own.net,+              connect = own.connect,+              patience = 10,+              logger = withSource "Courier" st.config.logger+            },+      note = \level -> logAt level (withSource "Publish" st.config.logger)+    }+  where+    own = st.config.store  -- GET Mempool / Events -- 

@@ -0,0 +1,764 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# OPTIONS_GHC -Wno-ambiguous-fields #-}++-- |+-- Module      : Haskoin.Store.Web.Publish+-- Copyright   : (c) Haskoin Developers+-- License     : MIT+-- Maintainer  : jprupp@protonmail.ch+-- Stability   : experimental+-- Portability : POSIX+--+-- 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 already is answered at once.+--+-- 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.+--+-- 5. __Answer__ when the transaction is in the mempool, or when the node+--    said that it refused it, or after 'Limits'.@wait@ seconds.+--+-- 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.+--+-- = 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.+--+-- * __One node.__ What is sent to one node reaches the others if it is+--   good. Sending it to many spreads what is bad.+--+-- * __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.+--+-- 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.+--+-- = 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.+module Haskoin.Store.Web.Publish+  ( -- * Publishing+    Publishing (..),+    Limits (..),+    Answer (..),+    Verdict (..),+    Direct (..),+    publish,++    -- * What the store can check+    Coin (..),+    Refusal (..),+    Rules (..),+    judge,+    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 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.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.POSIX (utcTimeToPOSIXSeconds)+import Data.Word (Word32, Word64)+import Haskoin+  ( Hash256,+    Message (..),+    MessageCommand (..),+    Network (..),+    NetworkAddress (..),+    OutPoint (..),+    Ping (..),+    Pong (..),+    Reject (..),+    Tx (..),+    TxHash,+    BlockHeight,+    InputVerdict (..),+    TxIn (..),+    TxOut (..),+    VarString (..),+    doubleSHA256,+    nullOutPoint,+    sockToHostAddress,+    txHash,+    txHashToHex,+  )+import Haskoin.Node+  ( LogLevel (..),+    Logger,+    PeerConfig (..),+    PeerEvent (..),+    WithConnection,+    buildVersion,+    peer,+    peerMessageDone,+    sendMessage,+    wrapPeer,+  )+import Haskoin.Node.Peer.Lock (Lock (..))+import Haskoin.Store.Common (StoreEvent (..), StoreRead (..))+import Haskoin.Store.Data (BlockRef (..), Spender (..), TxData (..), isCoinbaseTx)+import NQE (Publisher, newMailbox, receive, withPublisher, withSubscription)+import Network.Socket (SockAddr (..))+import System.Random (randomIO)+import UnliftIO+  ( STM,+    TVar,+    atomically,+    newTVarIO,+    onException,+    race,+    readTVar,+    readTVarIO,+    retrySTM,+    stateTVar,+    timeout,+    waitCatch,+    withAsync,+    writeTVar,+  )+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)++-- | What came of giving a transaction to a full node over its RPC.+data Direct+  = -- | the node took it into its mempool, or had it+    Sent+  | -- | the node refused it, with this reason+    Declined !Text+  | -- | there is no such node, or it did not answer+    Unavailable+  deriving (Eq, Show)++-- | The answer to a request to publish.+data Answer+  = -- | what came of handing it to a node+    Verdict !Verdict+  | -- | refused by the store, before anything was sent+    Invalid !Refusal+  | -- | the outbox is full+    Busy+  deriving (Eq, Show)++-- | An output that a transaction spends, as the store knows it.+data Coin+  = -- | it is there to spend, or only an unconfirmed transaction spends+    -- it+    Coin+      { -- | the output, as it is in the transaction that made it+        output :: !TxOut,+        -- | the height of the block that confirmed it, if one did+        mined :: !(Maybe BlockHeight),+        -- | whether a coinbase made it+        coinbase :: !Bool+      }+  | -- | a confirmed transaction has spent it+    Spent !TxHash+  | -- | the store does not know it+    Missing+  deriving (Eq, Show)++-- | Why the store refuses a transaction without sending it.+data Refusal+  = TooLarge !Int+  | NoInputs+  | NoOutputs+  | IsCoinbase+  | DuplicateInput !OutPoint+  | UnknownOutput !OutPoint+  | SpentOutput !OutPoint !TxHash+  | Overspent+  | Immature !OutPoint+  | NotFinal !Word32+  | TooHeavy !Int+  | Dust !Int+  | Forged !Int+  deriving (Eq)++instance Show Refusal where+  show (TooLarge n) = "The transaction is too large: " <> show n <> " bytes"+  show NoInputs = "The transaction has no inputs"+  show NoOutputs = "The transaction has no outputs"+  show IsCoinbase = "A coinbase transaction cannot be published"+  show (DuplicateInput o) = "The transaction spends the same output twice: " <> showOutPoint o+  show (UnknownOutput o) = "The transaction spends an output that this server does not know: " <> showOutPoint o+  show (SpentOutput o by) =+    "The transaction spends an output that a confirmed transaction has spent: "+      <> showOutPoint o+      <> " by "+      <> cs (txHashToHex by)+  show Overspent = "The outputs of the transaction are worth more than its inputs"+  show (Immature o) = "The transaction spends a coinbase that is not a hundred blocks old: " <> showOutPoint o+  show (NotFinal lock) = "The lock time of the transaction has not passed: " <> show lock+  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"++showOutPoint :: OutPoint -> String+showOutPoint o = cs (txHashToHex o.hash) <> ":" <> show o.index++-- | The largest transaction that a block of the network can hold, in+-- bytes. With SegWit a block weighs four million units at most, and a byte+-- of witness weighs one, so a transaction that is nearly all witness comes+-- close to four million bytes. Without it, the rule of Bitcoin Cash is a+-- million bytes for a transaction.+--+-- Nodes relay far smaller ones only, a hundred thousand bytes or so. The+-- store does not hold their rule, which is theirs to change: this is the+-- size past which no node can take the transaction.+maxTxSize :: Network -> Int+maxTxSize net+  | net.segWit = 4000000+  | otherwise = 1000000++-- | What the store knows of the chain and the network when it looks at a+-- transaction.+data Rules = Rules+  { net :: !Network,+    -- | what can be said of the signature of each input, given the+    -- outputs they spend: 'judgeInputs' of haskoin-core+    inputs :: !(Tx -> [TxOut] -> [InputVerdict]),+    -- | height of the best block+    height :: !BlockHeight,+    -- | median of the times of the last eleven blocks, which is the time+    -- that lock times are held to (BIP 113)+    medianTime :: !Word64+  }++-- | What the store can say of a transaction from its own index, given the+-- coin of each input in order ('coinOf').+--+-- Every check here is one whose answer a node would give too, and that+-- does not depend on what else is in a mempool:+--+-- * __What makes it no transaction__: no inputs or outputs, an input+--   twice, a coinbase, longer than a block can hold ('maxTxSize').+-- * __The coins__: each input spends an output that the store knows, that+--   no confirmed transaction has spent, and a coinbase only after a+--   hundred blocks. The outputs are not worth more than the inputs.+-- * __The lock time__ has passed, by height or by the median time, unless+--   every input waives it.+-- * __What nodes do not relay__: more than 'maxStandardSize', and an+--   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.+-- * __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+--   the store cannot read, is left to the node.+--+-- A conflict with an unconfirmed transaction is not a reason to refuse:+-- whether one may replace the other is for the node to say, and the+-- mempool of the store may hold what the network has dropped. The fee is+-- not checked either: what a node asks for changes with its mempool.+--+-- The answer for a transaction that passes says whether every signature+-- was verified, or names the first input that the store could not judge:+-- a script, a hash type other than all. Such a transaction may be good,+-- and only a full node can say. See 'publish' for what becomes of it.+judge :: Rules -> Tx -> [Coin] -> Either Refusal (Maybe Int)+judge rules tx coins = do+  when (size > maxTxSize rules.net) $ Left (TooLarge size)+  when (null tx.inputs) $ Left NoInputs+  when (null tx.outputs) $ Left NoOutputs+  when (any ((== nullOutPoint) . (.outpoint)) tx.inputs) $ Left IsCoinbase+  mapM_ (Left . DuplicateInput) (firstDuplicate (map (.outpoint) tx.inputs))+  spent <- mapM known (zip (map (.outpoint) tx.inputs) coins)+  -- 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)+  unless final $ Left (NotFinal tx.locktime)+  when (heavy > maxStandardSize rules.net) $ Left (TooHeavy heavy)+  mapM_ (Left . Dust) (take 1 [i | (i, o) <- zip [0 ..] tx.outputs, isDust rules.net o])+  let verdicts = zip [0 ..] (rules.inputs tx spent)+  mapM_ (Left . Forged) (take 1 [i | (i, InputForged) <- verdicts])+  return (listToMaybe [i | (i, InputUndecided) <- verdicts])+  where+    size = B.length (encode tx)+    -- what the limit of relay counts: weight with SegWit, bytes without+    heavy+      | rules.net.segWit = 3 * B.length (encode (tx {witness = []} :: Tx)) + size+      | otherwise = size+    known (_, Coin {output}) = Right output+    known (o, Spent by) = Left (SpentOutput o by)+    known (o, Missing) = Left (UnknownOutput o)+    -- a coinbase can be spent in the hundredth block after its own+    mature (o, Coin {coinbase = True, mined = Just h})+      | rules.height + 1 < h + 100 = Left (Immature o)+    mature _ = Right ()+    -- IsFinalTx of Bitcoin Core, for the block after the best one+    final+      | tx.locktime == 0 = True+      | tx.locktime < 500000000 = tx.locktime < rules.height + 1 || waived+      | otherwise = fromIntegral tx.locktime < rules.medianTime || waived+    waived = all ((== maxBound) . (.sequence)) tx.inputs+    firstDuplicate = go HashMap.empty+      where+        go _ [] = Nothing+        go seen (o : os)+          | HashMap.member o seen = Just o+          | otherwise = go (HashMap.insert o () seen) os++-- | The most that nodes relay: 400,000 units of weight with SegWit, which+-- is 100,000 bytes of a transaction without witness, and 100,000 bytes on+-- Bitcoin Cash.+maxStandardSize :: Network -> Int+maxStandardSize net+  | net.segWit = 400000+  | otherwise = 100000++-- | Whether an output is dust: worth less than three times what it costs,+-- at the lowest fee nodes relay, to make it and to spend it. Nodes do not+-- relay a transaction with one. This is @IsDust@ of Bitcoin Core at its+-- default of 3,000 satoshi a kilobyte, and of Bitcoin Cash Node: 546+-- satoshi for an output to a key hash, 294 to a witness key hash.+--+-- An output that cannot be spent, which starts with @OP_RETURN@, holds+-- data and may hold no value.+isDust :: Network -> TxOut -> Bool+isDust net o+  | unspendable = False+  | otherwise = toInteger o.value < 3 * toInteger (made + spent)+  where+    s = o.script+    unspendable = (not (B.null s) && B.head s == 0x6a) || B.length s > 10000+    made = 8 + lengthOfLength + B.length s+    lengthOfLength+      | B.length s < 0xfd = 1+      | B.length s <= 0xffff = 3+      | otherwise = 5+    -- what an input that spends it adds: less when its signature is in+    -- the witness+    spent+      | net.segWit && witnessProgram = 67+      | otherwise = 148+    witnessProgram =+      B.length s >= 4+        && B.length s <= 42+        && (B.head s == 0 || (B.head s >= 0x51 && B.head s <= 0x60))+        && fromIntegral (B.index s 1) == B.length s - 2++-- | The coin of an output, from the queries of a request.+coinOf :: StoreRead -> OutPoint -> IO Coin+coinOf q o =+  q.getTxData o.hash >>= \case+    Just td+      | not td.deleted,+        out : _ <- drop (fromIntegral o.index) td.tx.outputs ->+          q.getSpender o >>= \case+            Nothing -> return (coin td out)+            Just s ->+              q.getTxData s.txid >>= \case+                Just by | not by.deleted, Just _ <- confirmed by.block -> return (Spent s.txid)+                _ -> return (coin td out)+    _ -> return Missing+  where+    coin td out = Coin {output = out, mined = confirmed td.block, coinbase = isCoinbaseTx td.tx}+    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+-- 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+    rules :: !(IO Rules),+    -- | give the transaction to a full node over its RPC, where the store+    -- was given the RPC of one+    direct :: !(Tx -> IO Direct),+    -- | whether the store has the transaction, from the queries of the+    -- request+    has :: !(TxHash -> IO Bool),+    -- | 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+    courier :: !(SockAddr -> Tx -> IO Delivery),+    note :: !(LogLevel -> Text -> IO ())+  }++-- | Publish a transaction, and say what came of it. See the module header.+publish :: Publishing -> Tx -> IO Answer+publish p tx = do+  known <- p.has txid+  if known+    then return (Verdict Accepted)+    else+      (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+              v <- listening (send unverified) `onException` done Unreachable+              done v+              say v+              return (Verdict v)+  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+    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++seconds :: NominalDiffTime -> Int+seconds t = max 0 (round (t * 1000000))++-- | What a node did with a transaction handed to it.+data Delivery+  = -- | it answered the ping that followed: it is done with the+    -- transaction, and said nothing against it+    Took+  | -- | it sent a @reject@ message for the transaction, with this reason+    Rejected !Text+  | -- | it closed the connection after getting the transaction and+    -- before answering the ping+    Closed+  | -- | it kept the connection and did not answer in time+    NoAnswer+  | -- | no connection, or it ended before the transaction was sent+    NoConnection+  deriving (Eq, Show)++-- | What the courier needs.+data Courier = Courier+  { net :: !Network,+    connect :: !(SockAddr -> WithConnection),+    -- | seconds for all of it+    patience :: !NominalDiffTime,+    logger :: !Logger+  }++-- | Hand a transaction to a node on a connection made for it, and closed+-- after: the version handshake, the transaction, a @ping@, and what the+-- node answers until its @pong@.+--+-- The connection is a peer of "Haskoin.Node.Peer" with a publisher of its+-- own, so nothing of it reaches the peer manager or the block store.+deliver :: Courier -> SockAddr -> Tx -> IO Delivery+deliver c sa tx =+  withPublisher $ \pub -> withSubscription pub $ \sub -> do+    (inbox, mailbox) <- newMailbox+    busy <- newTVarIO Free+    pending <- newTVarIO 0+    sent <- newTVarIO False+    refused <- newTVarIO Nothing+    nonce <- randomIO+    token <- randomIO+    now <- getCurrentTime+    let config =+          PeerConfig+            { pub = pub,+              net = c.net,+              label = "courier " <> cs (show sa),+              connect = c.connect sa,+              logger = c.logger,+              lookupBlock = const (return Nothing)+            }+        node = wrapPeer config busy pending mailbox+        nowhere = NetworkAddress 0 (sockToHostAddress (SockAddrInet 0 0))+        there = NetworkAddress 0 (sockToHostAddress sa)+        version = buildVersion c.net nonce 0 nowhere there (floor (utcTimeToPOSIXSeconds now))+        next =+          receive sub >>= \case+            PeerMessage _ m -> peerMessageDone node >> return m+            _ -> next+        handshake theirs ours+          | theirs && ours = return ()+          | otherwise =+              next >>= \case+                MVersion _ -> MVerAck `sendMessage` node >> handshake True ours+                MVerAck -> handshake theirs True+                _ -> handshake theirs ours+        answer =+          next >>= \case+            MPong (Pong n) | n == token -> return ()+            MPing (Ping n) -> MPong (Pong n) `sendMessage` node >> answer+            MReject Reject {message = MCTx, reason} -> do+              atomically (writeTVar refused (Just (T.strip (T.decodeUtf8Lenient reason.get))))+              answer+            _ -> answer+        talk = do+          MVersion version `sendMessage` node+          handshake False False+          atomically (writeTVar sent True)+          MTx tx `sendMessage` node+          MPing (Ping token) `sendMessage` node+          answer+    withAsync (peer config node inbox) $ \a -> do+      -- when the connection ends, what the node sent before it did may+      -- still be on its way to 'answer': give it a moment+      r <- timeout (seconds c.patience) (race (waitCatch a >> threadDelay 200000) talk)+      was <- readTVarIO sent+      why <- readTVarIO refused+      return $ case (why, r) of+        (Just reason, _) -> Rejected reason+        (Nothing, Just (Right ())) -> Took+        (Nothing, Just (Left ())) -> if was then Closed else NoConnection+        (Nothing, Nothing) -> if was then NoAnswer else NoConnection

@@ -11,7 +11,7 @@   - url: './'  info:-  version: &version 1.10.1+  version: &version 1.11.0   title: Haskoin   contact:     name: JP Rupp@@ -1967,16 +1967,23 @@         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 the transaction was sent, not that the network accepted it.**-        The server does not validate transactions; it gives the transaction to half-        of its peers, which check it as they would any other. If they accept it, they-        relay it back, and it appears in the mempool and in balances within seconds.-        To know whether it was accepted, look for it with `/transaction/{txid}` or-        watch `/events`.+        **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. -        Five seconds later the server asks those peers for the transaction back. A-        peer that accepted it sends it, and the server imports it like any other-        transaction it hears about; a peer that refused it has nothing to send.+        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.++        A transaction that this server has already is answered 200 and not sent.+        Posting the same transaction again is always safe: it is sent once.       operationId: postTransaction       parameters:         - $ref: '#/components/parameters/prettyParam'@@ -2001,7 +2008,7 @@                        1486a7f1a2047ed6719fa1ad5484f15c37c104887c88ac00000000"       responses:         '200':-          description: Transaction accepted by network peer.+          description: A full node accepted the transaction, and this server has it.           content:             application/json:               schema:@@ -2009,18 +2016,47 @@               example:                 txid: 0b7cb07d848959fbd02ad6e2ed21fac888b8e8011c6b8c5362d05c703066ae67         '400':-          description: Transaction rejected.+          description: |+            The transaction was refused, and `message` says why:++            * 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.+            * 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.+            * 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.           content:             application/json:               schema:                 $ref: '#/components/schemas/Error'+        '413':+          description: |+            The body is longer than a transaction of the network can be in+            hexadecimal: 8,000,000 characters on networks with SegWit and+            2,000,000 on Bitcoin Cash, and some white space.+          content:+            application/json:+              schema:+                $ref: '#/components/schemas/Error'         '500':           description: |-            Publishing transaction failed for one of these reasons:+            The server could not find out whether the network took the+            transaction. Post the same transaction again to ask again. -            * No network peers available.-            * Timeout while publishing, most likely silent rejection.-            * Network peer disconnected while publishing transaction.+            * `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.           content:             application/json:               schema:

@@ -34,7 +34,7 @@ module Haskoin.Store.IntegrationSpec (spec) where  import Control.Lens ((&), (.~), (?~), (^.))-import Control.Monad (forM_, forever, unless, void, when)+import Control.Monad (forM_, forever, replicateM_, unless, void, when) import Data.Aeson (Value (..), eitherDecode, object, toJSON, (.=)) import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap@@ -66,13 +66,17 @@     Ctx,     Network (..),     OutPoint (..),+    Tx (..),     TxHash (..),+    TxIn (..),+    TxOut (..),     XPrvKey,     addrToText,     addressToScriptBS,     blockHashToHex,     bloomCreate,     bloomInsert,+    decodeHex,     deriveXPubKey,     encodeHex,     headerHash,@@ -92,13 +96,16 @@     xPubExport,     xPubWitnessAddr,   )-import Haskoin.Node (LogLevel (..), Logger (..), withConnection, withLogger)+import Haskoin qualified as H+import Haskoin.Node (LogLevel (..), Logger (..), getPeers, withConnection, withLogger) import Haskoin.Store   ( DeriveType (..),     Store (..),     StoreConfig (..),     WebConfig (..),+    WebLimits (..),     XPubSpec (..),+    decodeTxBody,     runWebSocket,     withStore,   )@@ -162,11 +169,20 @@       it "check the store against Bitcoin Core and Bitcoin Cash Node" $         pendingWith why     Right () -> prepareContext $ \ctx -> do+      forM_ [BitcoinCore, BitcoinCashNode] $ \kind ->+        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 (withEnv BitcoinCore ctx) $         describe "Bitcoin Core" (chainSpec BitcoinCore)       aroundAll (withEnv BitcoinCashNode ctx) $         describe "Bitcoin Cash Node" (chainSpec BitcoinCashNode) +-- | The name of a node, as people write it.+name :: NodeKind -> String+name BitcoinCore = "Bitcoin Core"+name BitcoinCashNode = "Bitcoin Cash Node"+ chainSpec :: NodeKind -> SpecWith Env chainSpec kind = do   it "sees payments up to exactly the gap, and those the gap reaches later" gapTest@@ -187,6 +203,11 @@   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+  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   it "speaks HTTP as browsers, proxies and long requests need it" httpTest   it "serves HTTPS, and nothing else, when given a certificate" tlsTest   it "tells each client of the transactions it chose, and takes up where it left" eventsTest@@ -232,14 +253,21 @@ gap = 32  withEnv :: NodeKind -> Ctx -> (Env -> IO ()) -> IO ()-withEnv kind ctx go = do+withEnv = withEnvOf True++-- | The same with a node that whitelists the store, as an operator's own+-- node should, or with one that does not. The second announces+-- 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   image <- testImage   withContainer (redisContainer image) $ \redis -> do     redisPort <- hostPort redis 6379     let redisURL = "redis://127.0.0.1:" <> show redisPort     waitRedis redisURL     writeOldKeys redisURL-    withContainer (nodeContainer kind image) $ \c -> do+    withContainer ((if whitelisted then nodeContainer else strangerContainer) kind image) $ \c -> do       rpcPort <- hostPort c 18443       p2pPort <- hostPort c 18444       let node =@@ -256,10 +284,11 @@       void $ generateTo node 150 miner       withRamDir $ \dir -> withTestLogger $ \logger -> do         let net = nodeNetwork kind-            cfg = storeConfig net ctx logger dir redisURL p2pPort False+            cfg = (storeConfig net ctx logger dir redisURL p2pPort False) {syncMempool = whitelisted}         withStore cfg $ \store -> do           listening $ \(cachedSock, cachedPort) -> listening $ \(plainSock, plainPort) -> do-            let web s = runWebSocket (webConfig logger s)+            let patient c = c {limits = c.limits {publishTimeout = 45}} :: WebConfig+                web s = runWebSocket ((if whitelisted then id else patient) (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 ->@@ -345,7 +374,8 @@       maxLaggingBlocks = 100,       maxPendingTxs = 10000,       minPeers = 0,-      limits = def,+      -- a short wait, for the transactions that a node takes and says nothing of+      limits = def {publishTimeout = 3},       version = "test",       noMempool = False,       stats = Nothing,@@ -356,6 +386,7 @@       noBlockchainInfo = False,       healthCheckInterval = 5,       accessLog = False,+      nodeRpc = Nothing,       tls = Nothing,       logger = logger     }@@ -1697,6 +1728,372 @@   let described = BL.toStrict (reference ^. Wreq.responseBody)   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.+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+  inNode <- rpc env.node "getrawmempool" []+  arr inNode `shouldSatisfy` elem (String (cs firstId))+  publishTx env first >>= \(code, _) -> code `shouldBe` 200+  -- 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+  publishTx env orphan >>= \(code, v) -> do+    code `shouldBe` 400+    fmap (T.isInfixOf "does not know") (textField "message" v) `shouldBe` Just True+  -- a forged one: the outputs are not those that were signed. The wallets+  -- of both nodes pay to one key, so the store can tell by itself+  second <- unsent env+  let forged = cheaper second+  publishTx env forged >>= \(code, v) -> do+    code `shouldBe` 400+    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+  free <- unsentFree env+  (code, v) <- publishTx env free+  case env.node.kind of+    -- Bitcoin Cash Node says why+    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+  (unpaid, _) <- getJSON env.plain ("/transaction/" <> cs (txHashToHex (txHash free)))+  unpaid `shouldBe` 404+  publishTx env second >>= \(c, _) -> c `shouldBe` 200+  -- 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+  -- an output that a block has spent+  void $ mine env 1+  publishTx env (cheaper first) >>= \(c, e) -> do+    c `shouldBe` 400+    fmap (T.isInfixOf "confirmed transaction has spent") (textField "message" e) `shouldBe` Just True++-- | A transaction of the node's wallet, signed and not sent.+unsent :: Env -> IO Tx+unsent env = do+  to <- getNewAddress env.node+  raw <-+    rpc env.node "createrawtransaction" [toJSON ([] :: [Value]), object [Key.fromText to .= btc 300000]]+  funded <- rpc env.node "fundrawtransaction" [raw]+  signed <- rpc env.node "signrawtransactionwithwallet" [funded ! "hex"]+  case signed ! "hex" of+    String h -> either fail return (decodeTxBody env.net (cs h))+    other -> fail ("No transaction: " <> show other)++-- | Sign a raw transaction with the wallet of the node, with a hash type+-- if one is given.+signed :: Env -> Maybe Text -> Value -> IO Tx+signed env hashType raw = do+  let how = maybe [] (\t -> [toJSON ([] :: [Value]), String t]) hashType+  answer <- rpc env.node "signrawtransactionwithwallet" ([raw] <> how)+  case answer ! "hex" of+    String h -> either fail return (decodeTxBody env.net (cs h))+    other -> fail ("No transaction: " <> show other)++-- | A transaction of the node's wallet that pays no fee: one coin, sent+-- whole to one address.+unsentFree :: Env -> IO Tx+unsentFree env = do+  coins <- arr <$> rpc env.node "listunspent" []+  to <- getNewAddress env.node+  case coins of+    c : _ -> do+      let spent = object ["txid" .= (c ! "txid"), "vout" .= (c ! "vout")]+      rpc env.node "createrawtransaction" [toJSON [spent], object [Key.fromText to .= (c ! "amount")]]+        >>= signed env Nothing+    [] -> fail "The wallet has no coin"++-- | The same transaction paying one satoshi less: another transaction,+-- with signatures that are not of it.+cheaper :: Tx -> Tx+cheaper tx = tx {outputs = [o {value = o.value - 1} | o <- tx.outputs]}++-- | Post a transaction to publish.+publishTx :: Env -> Tx -> IO (Int, Value)+publishTx env tx = publishBody env (cs (encodeHex (encode tx)))++publishBody :: Env -> C8.ByteString -> IO (Int, Value)+publishBody env bytes = do+  r <- Wreq.postWith opts (env.plain <> "/transactions") bytes+  return (r ^. Wreq.responseStatus . Wreq.statusCode, body (r ^. Wreq.responseBody))+  where+    opts = Wreq.defaults & Wreq.checkResponse ?~ (\_ _ -> return ())++-- | A good transaction whose input the store cannot judge, because it+-- would have to run a script: it spends a coin locked by a script of its+-- own, here one that anyone can spend, which the wallet of the node pays+-- first. The script is in a witness script hash on Bitcoin, and in a+-- script hash on Bitcoin Cash.+unjudged :: Env -> IO Tx+unjudged env = do+  let script = "\x51" :: C8.ByteString+      locked+        | env.net.segWit = H.PayWitnessScriptHash (sha256 script)+        | otherwise = H.PayScriptHash (H.addressHash script)+  (coin, _) <- payScript env locked+  tx <- spendingTo env coin+  return $+    if env.net.segWit+      then tx {witness = [[script]]}+      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.+--+-- 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.+strangerTest :: Env -> IO ()+strangerTest env = do+  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))+  unsent env >>= published+  -- the store follows the chain+  void $ mine env 1+  where+    published tx = do+      publishTx env tx >>= \(code, _) -> code `shouldBe` 200+      (seen, _) <- getJSON env.plain ("/transaction/" <> cs (txHashToHex (txHash tx)))+      seen `shouldBe` 200++-- | 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.+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+      config url = (webConfig logger env.store) {nodeRpc = Just url} :: WebConfig+      asking = env {plain = "http://127.0.0.1:" <> show port} :: Env+      unanswered = env {plain = "http://127.0.0.1:" <> show deafPort} :: Env+      up e = (== 200) . fst <$> getJSON e.plain "/block/best?notx=true"+      refused why (code, v) = (code, fmap (T.isInfixOf why) (textField "message" v)) `shouldBe` (400, Just True)+  -- nothing listens on port 1+  let withBoth go =+        withAsync (runWebSocket (config rpcURL) sock) $ \a ->+          withAsync (runWebSocket (config "http://127.0.0.1:1/") deaf) $ \b ->+            link a >> link b >> go+  withBoth $ do+    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+    -- 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++-- | Pay a script from the wallet of the node, and give the coin: where it+-- is, and the output that holds it.+payScript :: Env -> H.ScriptOutput -> IO (OutPoint, TxOut)+payScript env so = do+  address <- maybe (fail "No address for the script") return (H.outputAddress env.net env.ctx so)+  txid <- sendMany env.node [(addrText env address, 300000)]+  waitSynced env+  funding <- getRawTx env.node txid+  vout <- case [ numV n+               | o <- arr (funding ! "vout"),+                 Just n <- [field "n" o],+                 (textField "hex" =<< field "scriptPubKey" o) == Just (scriptHex env address)+               ] of+    v : _ -> return v+    [] -> fail "No output to the script"+  spent <- maybe (fail "Not a transaction id") return (hexToTxHash txid)+  return (OutPoint spent (fromIntegral vout), TxOut 300000 (H.marshal env.ctx so))++-- | A transaction that spends a coin of 300,000 to the wallet of the+-- node, with nothing in its input yet.+spendingTo :: Env -> OutPoint -> IO Tx+spendingTo env coin = do+  to <- getNewAddress env.node+  info <- rpc env.node "getaddressinfo" [String to]+  back <- maybe (fail "No script for the address of the wallet") return (textField "scriptPubKey" info >>= decodeHex)+  return+    Tx+      { version = 2,+        inputs = [TxIn {outpoint = coin, script = "", sequence = maxBound}],+        outputs = [TxOut {value = 299000, script = back}],+        witness = [],+        locktime = 0+      }++-- | A Schnorr signature of Bitcoin Cash, made the plain way: this is a+-- test, and the nonce is no secret worth keeping. haskoin-core verifies+-- these and does not make them.+cashSchnorr :: Ctx -> H.SecKey -> H.Hash256 -> C8.ByteString+cashSchnorr ctx k h = case [sig | Just sig <- map attempt [1 ..]] of+  sig : _ -> sig+  [] -> error "No nonce"+  where+    n = 0xfffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141 :: Integer+    p = 2 ^ (256 :: Int) - 2 ^ (32 :: Int) - 977 :: Integer+    word256 i = let b = H.integerToBS i in C8.replicate (32 - C8.length b) '\0' <> b+    public = H.exportPubKey ctx True (H.derivePubKey ctx k)+    attempt nonce = do+      r <- H.derivePubKey ctx <$> H.secKey (word256 nonce)+      let (x, y) = C8.splitAt 32 (C8.drop 1 (H.exportPubKey ctx False r))+          square = powMod (H.bsToInteger y) ((p - 1) `div` 2) == 1+          e = H.bsToInteger (encode (H.sha256 (x <> public <> encode h))) `mod` n+      if square then Just (x <> word256 ((nonce + e * H.bsToInteger k.get) `mod` n)) else Nothing+    powMod _ 0 = 1 :: Integer+    powMod b i+      | even i = let half = powMod b (i `div` 2) in half * half `mod` p+      | otherwise = b * powMod b (i - 1) `mod` p++-- | Spends of a coin that two of three keys open, published through a+-- peer: the store has no RPC here, and sends a peer only what it+-- verified. Each is made with keys of the test, not by the wallet of the+-- node, and the node takes it.+--+-- On both networks, the multisig of old, with ECDSA signatures. On+-- Bitcoin, the multisig of Taproot, a script with a Schnorr signature for+-- each key that signs. On Bitcoin Cash, the same multisig as of old+-- signed with Schnorr signatures, where a field of bits says which keys+-- signed. The same spend paying one satoshi less, which its signatures+-- are not of, is refused.+multisigTest :: Env -> IO ()+multisigTest env = do+  let ctx = env.ctx+      secret n = fromMaybe (error "Not a secret key") (H.secKey (C8.replicate 31 '\0' <> C8.singleton n))+      secrets = map secret "\x0b\x0c\x0d"+      points = map (H.derivePubKey ctx) secrets+      twoOfThree = H.PayMulSig (map (H.wrapPubKey True) points) 2+      right = either (fail . ("Could not make the transaction: " <>)) return+      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+      -- signed by the first two keys, the old way+      old locked hashType = do+        (coin, out) <- payScript env locked+        unsigned <- spendingTo env coin+        let input =+              H.SigInput+                { script = locked,+                  value = out.value,+                  outpoint = coin,+                  sighash = hashType,+                  redeem = Just twoOfThree+                }+        right (H.signTx env.net ctx unsigned [input] (take 2 secrets)) >>= published+  case env.kind of+    BitcoinCore -> do+      inWitness <- right (H.payToWitnessScriptAddress ctx twoOfThree)+      old (fromMaybe (error "No script") (H.addressToOutput inWitness)) H.sigHashAll+      -- Taproot: signed by the first and the third key+      let xOnly = C8.drop 1 . H.exportPubKey ctx True+          leaf =+            H.Script $+              [H.opPushData (xOnly (head points)), H.OP_CHECKSIG]+                <> concat [[H.opPushData (xOnly k), H.OP_CHECKSIGADD] | k <- drop 1 points]+                <> [H.OP_2, H.OP_NUMEQUAL]+          internal = H.derivePubKey ctx (secret '\x0e')+          tree = H.TaprootOutput {internalKey = internal, mast = Just (H.MASTLeaf H.tapscriptLeafVersion leaf)}+      (coin, out) <- payScript env (H.taprootScriptOutput ctx tree)+      unsigned <- spendingTo env coin+      let leafOf = Just (H.leafHash H.tapscriptLeafVersion leaf, 0xffffffff)+      digest <- right (H.taprootSigHash unsigned [out] 0 H.sigHashDefault Nothing leafOf)+      let sign k = (H.signSchnorr ctx k (H.hashToMsg digest)).get+          spend =+            H.ScriptPathSpend+              H.ScriptPathData+                { annex = Nothing,+                  -- an item for each key, that of the last key first+                  stack = [sign (secrets !! 2), "", sign (head secrets)],+                  script = leaf,+                  extIsOdd = odd (H.keyParity ctx (H.taprootOutputKey ctx tree)),+                  leafVersion = H.tapscriptLeafVersion,+                  internalKey = internal,+                  control = [],+                  opaqueScript = Nothing+                }+      witness <- right (H.encodeTaprootWitness ctx spend)+      published (unsigned {witness = [witness]} :: Tx)+    BitcoinCashNode -> do+      inScript <- right (H.payToScriptAddress ctx twoOfThree)+      let locked = fromMaybe (error "No script") (H.addressToOutput inScript)+      old locked (H.setForkIdFlag H.sigHashAll)+      -- Schnorr signatures of the first and the third key: bits 0 and 2+      (coin, out) <- payScript env locked+      unsigned <- spendingTo env coin+      code <- right (H.encodeOutput ctx twoOfThree)+      digest <- right (H.txSigHashForkId env.net unsigned code out.value 0 (H.setForkIdFlag H.sigHashAll))+      let sign k = cashSchnorr ctx k digest <> "\x41"+          pushed = [sign (head secrets), sign (secrets !! 2), H.marshal ctx twoOfThree]+          items = [H.OP_5] <> map H.opPushData pushed+      published (unsigned {inputs = [i {script = encode (H.Script items)} | i <- unsigned.inputs]} :: Tx)++-- | Tokens of Bitcoin Cash. A transaction of the node's wallet that makes+-- tokens, and one that spends the output that holds them, are published:+-- the store verifies their signatures, which cover the tokens, and does+-- not take them for forged. A forged spend of the tokens is refused.+tokenTest :: Env -> IO ()+tokenTest env = do+  coins <- arr <$> rpc env.node "listunspent" []+  to <- getNewAddress env.node+  -- the category of new tokens is the transaction of a first output spent+  coin <- case [c | c <- coins, numV (c ! "vout") == 0] of+    c : _ -> return c+    [] -> fail "The wallet has no first output"+  let amount less = case coin ! "amount" of+        Number n -> Number (n - less)+        other -> other+      holding less =+        object+          [ Key.fromText to+              .= object+                [ "amount" .= amount less,+                  "tokenData" .= object ["category" .= (coin ! "txid"), "amount" .= ("1000" :: Text)]+                ]+          ]+      spending txid = toJSON [object ["txid" .= txid, "vout" .= (0 :: Int)]]+      published tx = publishTx env tx >>= \(code, v) -> (code, v) `shouldSatisfy` ((== 200) . fst)+  genesis <-+    rpc env.node "createrawtransaction" [spending (coin ! "txid"), toJSON [holding 0.001]]+      >>= signed env Nothing+  published genesis+  spend <-+    rpc env.node "createrawtransaction" [spending (txHashToHex (txHash genesis)), toJSON [holding 0.002]]+      >>= signed env Nothing+  publishTx env (cheaper spend) >>= \(code, v) -> do+    code `shouldBe` 400+    fmap (T.isInfixOf "does not verify") (textField "message" v) `shouldBe` Just True+  published spend  -- | The events of the server over a WebSocket. A client that says nothing -- hears of every transaction; one that names an extended public key, an

@@ -0,0 +1,241 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++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 Data.ByteString qualified as B+import Data.Serialize (encode)+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Word (Word32, Word64)+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++-- | An output, told apart by a number.+output :: Word32 -> OutPoint+output n = OutPoint (TxHash (doubleSHA256 (encode n))) n++-- | A transaction that spends outputs and pays a value.+spending :: [OutPoint] -> Word64 -> Tx+spending ins v =+  Tx+    { version = 2,+      inputs = [TxIn {outpoint = o, script = "", sequence = maxBound} | o <- ins],+      outputs = [TxOut {value = v, script = B.replicate 25 1}],+      witness = [],+      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}++-- | 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.+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+      | otherwise = InputVerified++-- | 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,+              has = \h -> elem h <$> 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)++spec :: Spec+spec = prepareContext $ \ctx -> 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" $+      check tx [held 1000, held 500] `shouldBe` Right Nothing+    it "refuses an output it does not know, and one spent in a block" $ do+      check tx [held 1000, Missing] `shouldBe` Left (UnknownOutput (output 2))+      let by = (output 9).hash+      check tx [Spent by, held 1000] `shouldBe` Left (SpentOutput (output 1) by)+    it "refuses outputs worth more than the inputs" $+      check tx [held 1000, held 499] `shouldBe` Left Overspent+    it "refuses the same output twice, a coinbase, and nothing to spend or pay" $ do+      check (spending [output 1, output 1] 1) [held 1, held 1] `shouldBe` Left (DuplicateInput (output 1))+      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+      check one [young 902] `shouldBe` Left (Immature (output 1))+      check one [young 901] `shouldBe` Right Nothing+      check one [(young 902) {coinbase = False}] `shouldBe` Right Nothing+    it "refuses a lock time that has not passed, unless every input waives it" $ do+      let locked n = (spending [output 1] 900) {locktime = n, inputs = [TxIn (output 1) "" 0]} :: Tx+      check (locked 1000) [held 1000] `shouldBe` Right Nothing+      check (locked 1001) [held 1000] `shouldBe` Left (NotFinal 1001)+      check (locked 1599999999) [held 1000] `shouldBe` Right Nothing+      check (locked 1600000000) [held 1000] `shouldBe` Left (NotFinal 1600000000)+      check ((locked 1001) {inputs = [TxIn (output 1) "" maxBound]} :: Tx) [held 1000] `shouldBe` Right Nothing+    it "refuses an output worth less than it costs to spend, and not one that holds data" $ do+      let paying v script = (spending [output 1] 0) {outputs = [TxOut v script]} :: Tx+          keyHash = "\x76\xa9\x14" <> B.replicate 20 7 <> "\x88\xac"+          witnessKeyHash = "\x00\x14" <> B.replicate 20 7+      check (paying 545 keyHash) [held 1000] `shouldBe` Left (Dust 0)+      check (paying 546 keyHash) [held 1000] `shouldBe` Right Nothing+      check (paying 293 witnessKeyHash) [held 1000] `shouldBe` Left (Dust 0)+      check (paying 294 witnessKeyHash) [held 1000] `shouldBe` Right Nothing+      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+      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++  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 "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 "sends nothing for what the store has, or cannot be valid" $+      desk ctx (\_ _ -> return Took) $ \p sent -> do+        publish p {has = \_ -> return True} tx `shouldReturn` Verdict Accepted+        publish p {coin = \_ -> return Missing} tx+          `shouldReturn` Invalid (UnknownOutput (output 1))+        sent `shouldReturn` 0+    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+    it "refuses a transaction larger than nodes relay" $+      desk ctx (\_ _ -> return Took) $ \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+    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