diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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" diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store -version: 1.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 diff --git a/integration/Haskoin/Store/Integration/Node.hs b/integration/Haskoin/Store/Integration/Node.hs --- a/integration/Haskoin/Store/Integration/Node.hs +++ b/integration/Haskoin/Store/Integration/Node.hs @@ -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 diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -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 diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -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 -- diff --git a/src/Haskoin/Store/Web/Publish.hs b/src/Haskoin/Store/Web/Publish.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Web/Publish.hs @@ -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 diff --git a/swagger.yaml b/swagger.yaml --- a/swagger.yaml +++ b/swagger.yaml @@ -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: diff --git a/test/Haskoin/Store/IntegrationSpec.hs b/test/Haskoin/Store/IntegrationSpec.hs --- a/test/Haskoin/Store/IntegrationSpec.hs +++ b/test/Haskoin/Store/IntegrationSpec.hs @@ -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 diff --git a/test/Haskoin/Store/Web/PublishSpec.hs b/test/Haskoin/Store/Web/PublishSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Store/Web/PublishSpec.hs @@ -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