haskoin-store 1.11.0 → 1.12.0
raw patch · 10 files changed
+648/−325 lines, 10 filesdep −aeson-prettyPVP ok
version bump matches the API change (PVP)
Dependencies removed: aeson-pretty
API changes (from Hackage documentation)
- Haskoin.Store.Web: instance GHC.Classes.Eq Haskoin.Store.Web.SerialAs
- Haskoin.Store.Web: instance GHC.Internal.Show.Show Haskoin.Store.Web.SerialAs
+ Haskoin.Store.Web.Pieces: around :: Builder -> Builder -> [IO Builder] -> [IO Builder]
+ Haskoin.Store.Web.Pieces: hexOf :: Serial a => a -> Builder
+ Haskoin.Store.Web.Pieces: listPieces :: (b -> Encoding) -> [IO [b]] -> IO [IO Builder]
+ Haskoin.Store.Web.Pieces: pieced :: Int -> ([k] -> IO b) -> [k] -> [IO b]
+ Haskoin.Store.Web.Pieces: piecesResponse :: ResponseHeaders -> IO () -> [IO Builder] -> IO Response
Files
- CHANGELOG.md +41/−1
- README.md +23/−6
- haskoin-store.cabal +3/−7
- src/Haskoin/Store/Web.hs +263/−249
- src/Haskoin/Store/Web/Pieces.hs +133/−0
- src/Haskoin/Store/Web/Publish.hs +2/−1
- swagger.yaml +21/−56
- test/Haskoin/Store/IntegrationSpec.hs +62/−3
- test/Haskoin/Store/Web/PiecesSpec.hs +78/−0
- test/Haskoin/Store/WebSpec.hs +22/−2
CHANGELOG.md view
@@ -4,7 +4,47 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html) -## [Unreleased]+## [1.12.0] - 2026-11-13++Long lists of transactions and raw blocks are sent while they are read,+and pretty JSON is gone.++### Removed+- **Pretty JSON.** The `pretty` parameter is gone from every endpoint, and+ a request with it is refused like any other unknown parameter. Pipe an+ answer through a tool such as `jq` to read it indented.++### Changed+- **Long answers are sent while they are read.** The endpoints that answer+ with all the transactions that the database lists somewhere read them a+ hundred at a time, and send each hundred while they read the next:+ - `/address/:addr/transactions/full`, `/address/transactions/full` and+ `/xpub/:xpub/transactions/full`;+ - `/transactions/block/:block` and `/transactions/block/:block/raw`;+ - the raw blocks: `/block/:block/raw`, `/block/best/raw`,+ `/block/height/:height/raw`, `/block/time/:time/raw` and+ `/block/mtp/:time/raw`;+ - `/blockchain/rawblock/:block`, in JSON and in hex, and+ `/blockchain/block-height/:height`.++ The bytes are the same. With 5,000 transactions of an address (15 MB) on+ regtest, the first byte left after 11 ms where it took 96 ms, and sixteen+ such requests at once took 197 MB of memory where they took 1,014 MB. The+ whole response takes as long as before: encoding JSON is most of it.+- These responses have no `Content-Length`. What can refuse the request is+ checked before the first byte; a failure after it ends the response+ before it is complete, where it used to be an error with a status.+- Lists that the client names, such as `/transactions?txids=`, are read+ whole before they are answered, as before: what is asked for may not be+ there.+- The timings of these endpoints count the whole response, the time that+ the client takes to read it included.+- No longer depends on aeson-pretty.+- **The warning of a slow request counts the whole response**, until its+ last byte is sent. It counted only the time to make the status, which+ for an answer sent while it is read is the first hundred transactions.+ A client or proxy that reads slowly can now make a request slow. A+ response cut short is logged too, ending in `, cut short`. ## [1.11.0] - 2026-11-12
README.md view
@@ -82,7 +82,7 @@ | Xpubs | Balances, transactions and UTXO of extended public keys, for legacy, nested SegWit and native SegWit addresses, with an optional Redis cache for large wallets | | Blocks and txs | Lookup by hash, height or time; raw serialized forms; transactions of a block | | Mempool | Persistent, indexed by arrival time, with replace-by-fee on BTC and pruning of old entries |-| Formats | JSON, or pretty JSON |+| Formats | JSON | | Live events | New blocks and transactions as a JSON stream or over a WebSocket | | Compatibility | Endpoints in the style of Blockchain.info under `/blockchain/` | | Operations | Health check, StatsD metrics, RocksDB memory limits, Docker image |@@ -107,7 +107,7 @@ -e NET=btc -e DISCOVER=true \ -v haskoin-store-data:/home/haskoin/.haskoin-store \ haskoin-store-curl 'http://localhost:3000/block/best?pretty=true'+curl -s 'http://localhost:3000/block/best' | jq ``` The first sync downloads and indexes the whole chain, which takes a long@@ -183,7 +183,7 @@ SegWit, `segwit` for native SegWit): ```sh-curl 'localhost:3000/xpub/xpub6C...?derive=segwit&pretty=true'+curl -s 'localhost:3000/xpub/xpub6C...?derive=segwit' | jq ``` The answer has confirmed and unconfirmed balances, and the index of the last@@ -492,7 +492,8 @@ one server, `./`, so requests tried from the page go to the server that served it, also behind a proxy that mounts it under a path such as `/btc/`. The reference always matches the version that is running.-- Answers are JSON. Add `?pretty=true` for indented JSON.+- Answers are JSON, without spaces. Pipe them through `jq` to read them+ indented. - Lists are paged with `limit` and `offset`, newest first. `height` begins a page at a transaction hash, a block hash, a block height or a Unix time instead.@@ -509,6 +510,19 @@ may send from another site. - **Answers are compressed** for a client that sends `Accept-Encoding: gzip`, but for the stream of events.+- **Long answers are sent while they are read.** The endpoints that answer+ with all the transactions that the database lists somewhere read them a+ hundred at a time and send each hundred while they read the next: the+ full transactions of addresses and of an xpub (`.../transactions/full`),+ the transactions of a block (`/transactions/block/:block` and its `/raw`),+ the raw blocks (`/block/.../raw`), and the blocks of the Blockchain.info+ API (`/blockchain/rawblock/:block`, `/blockchain/block-height/:height`).+ The first byte leaves sooner and the server holds two hundred+ transactions, not the whole answer. These answers have no+ `Content-Length`. What can refuse a request is checked before the first+ byte; a failure after it ends the answer before it is complete. Lists+ that the client names, such as `/transactions?txids=`, are read whole+ first, because what is asked for may not be there. - **Long lists go in a body.** The endpoints that take a list of addresses, blocks, heights or transactions also take it under `POST`, as a form (`application/x-www-form-urlencoded`), so that it does not@@ -726,6 +740,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.Pieces` | Answers that are sent while they are read | | `Haskoin.Store.Web.Publish` | Publishing a transaction through a full node | The rules and queries of version 20 (`Haskoin.Store.Logic`,@@ -843,8 +858,10 @@ behind the headers` as a warning, and `Healthy again`. A store that is still syncing says `Not healthy yet` once, which is not a warning. - **Slow requests.** A warning for a request that took `--slow-request`- seconds or more to answer, with the request and how long it took. The- stream of events is left out.+ seconds or more to answer, with the request and how long it took, until+ the last byte was sent. A client or proxy that reads slowly can make a+ request slow too. A response cut short ends in `, cut short`. The stream+ of events is left out. - **Every request**, with `--access-log`, which is off by default: `203.0.113.7 GET /block/best HTTP/1.1: 200 OK, 0.4 ms`. A public server usually has a proxy in front that keeps this log better. The
haskoin-store.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store-version: 1.11.0+version: 1.12.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.Pieces Haskoin.Store.Web.Publish Haskoin.Store.Web.Router other-modules:@@ -94,7 +95,6 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: aeson >=2.2.5.1 && <2.3- , aeson-pretty >=0.8.11 && <0.9 , base >=4.21.2.0 && <4.22 , base16 ==2.0.* , bytes >=0.17.5 && <0.18@@ -159,7 +159,6 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: aeson >=2.2.5.1 && <2.3- , aeson-pretty >=0.8.11 && <0.9 , base >=4.21.2.0 && <4.22 , base16 ==2.0.* , bytes >=0.17.5 && <0.18@@ -221,7 +220,6 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts "-with-rtsopts=-N --disable-delayed-os-memory-return" build-depends: aeson >=2.2.5.1 && <2.3- , aeson-pretty >=0.8.11 && <0.9 , base >=4.21.2.0 && <4.22 , base16 ==2.0.* , bytes >=0.17.5 && <0.18@@ -293,6 +291,7 @@ Haskoin.Store.OutageSpec Haskoin.Store.TestBlocks Haskoin.Store.Web.EventsSpec+ Haskoin.Store.Web.PiecesSpec Haskoin.Store.Web.PublishSpec Haskoin.Store.Web.RouterSpec Haskoin.Store.WebSpec@@ -311,7 +310,6 @@ build-depends: QuickCheck >=2.17.1.0 && <2.18 , aeson >=2.2.5.1 && <2.3- , aeson-pretty >=0.8.11 && <0.9 , base >=4.21.2.0 && <4.22 , base16 ==2.0.* , base64 >=1.0.1 && <1.1@@ -380,7 +378,6 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N build-depends: aeson >=2.2.5.1 && <2.3- , aeson-pretty >=0.8.11 && <0.9 , base >=4.21.2.0 && <4.22 , base16 ==2.0.* , bytes >=0.17.5 && <0.18@@ -444,7 +441,6 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N2 build-depends: aeson >=2.2.5.1 && <2.3- , aeson-pretty >=0.8.11 && <0.9 , base >=4.21.2.0 && <4.22 , base16 ==2.0.* , bytes >=0.17.5 && <0.18
src/Haskoin/Store/Web.hs view
@@ -15,7 +15,7 @@ -- -- 'runWeb' serves the endpoints described in "Haskoin.Store.WebCommon" and a -- set of endpoints compatible with the Blockchain.info API under--- @\/blockchain\/@. Responses are JSON, pretty-printed with @?pretty=true@.+-- @\/blockchain\/@. Responses are JSON. -- New blocks and mempool transactions are streamed at @\/events@, as lines -- of JSON or over a WebSocket. --@@ -113,23 +113,19 @@ import Data.Aeson ( Encoding, ToJSON (..),- Value, (.=), ) import Data.Aeson.KeyMap qualified as KeyMap import Data.Aeson qualified as A-import Data.Aeson.Encode.Pretty- ( Config (..),- defConfig,- encodePretty',- ) import Data.Aeson.Encoding ( encodingToLazyByteString,+ fromEncoding, list,+ unsafeToEncoding, ) import Data.Aeson.Types (parseMaybe) import Data.ByteString.Base16 (decodeBase16, parseBase16)-import Data.ByteString.Builder (lazyByteString)+import Data.ByteString.Builder (Builder, lazyByteString) import Data.ByteString.Char8 qualified as C import Data.ByteString.Lazy qualified as L import Data.Bytes.Get@@ -137,21 +133,19 @@ import Data.Bytes.Serial import Data.Char (isSpace) import Data.Default (Default (..))-import Data.Function ((&)) import Data.HashMap.Strict (HashMap) 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, fromJust, fromMaybe, isJust,+ listToMaybe, mapMaybe, maybeToList, )@@ -220,6 +214,7 @@ import Haskoin.Store.Manager import Haskoin.Store.Web.Docs (swaggerPage, swaggerYaml) import Haskoin.Store.Web.Events+import Haskoin.Store.Web.Pieces (around, hexOf, listPieces, pieced, piecesResponse) import Haskoin.Store.Web.Publish qualified as Publish import Haskoin.Store.Web.Router hiding (header) import Haskoin.Store.WebCommon@@ -230,7 +225,8 @@ unsubscribe, ) import Network.HTTP.Types- ( Status (..),+ ( ResponseHeaders,+ Status (..), hContentType, methodGet, methodPost,@@ -311,6 +307,7 @@ newIORef, newTQueueIO, newTVarIO,+ onException, race_, readIORef, readTQueue,@@ -625,14 +622,6 @@ t2 <- time addTiming (df m) (t2 - t1) --- | Encoding of a response.-data SerialAs- = -- | compact JSON- SerialAsJSON- | -- | indented JSON, for @?pretty=true@- SerialAsPrettyJSON- deriving (Eq, Show)- ------------------- -- Path Handlers -- -------------------@@ -1047,24 +1036,28 @@ pathHealth st, plainList ["limit", "offset"] (\r -> GetMempool <$> opt r <*> off r) (handleMempool st), marshalledList ["blocks", "notx"] (\r -> GetBlocks <$> need r <*> dflt r) (handleBlocks st),- plain [] (\r -> GetBlockRaw <$> cap r) (handleBlockRaw st),- plain [] (\_ -> return GetBlockBestRaw) (handleBlockBestRaw st),+ pieces (.blockRaw) [] (\r -> GetBlockRaw <$> cap r) (handleBlockRaw st),+ pieces (.blockRaw) [] (\_ -> return GetBlockBestRaw) (handleBlockBestRaw st), marshalledList ["notx"] (\r -> GetBlockLatest <$> dflt r) (handleBlockLatest st), marshalledList ["heights", "notx"] (\r -> GetBlockHeights <$> need r <*> dflt r) (handleBlockHeights st),- plain [] (\r -> GetBlockHeightRaw <$> cap r) (handleBlockHeightRaw st),- plain [] (\r -> GetBlockTimeRaw <$> cap r) (handleBlockTimeRaw st),- plain [] (\r -> GetBlockMTPRaw <$> cap r) (handleBlockMTPRaw st),+ pieces (.blockRaw) [] (\r -> GetBlockHeightRaw <$> cap r) (handleBlockHeightRaw st),+ pieces (.blockRaw) [] (\r -> GetBlockTimeRaw <$> cap r) (handleBlockTimeRaw st),+ pieces (.blockRaw) [] (\r -> GetBlockMTPRaw <$> cap r) (handleBlockMTPRaw st), marshalledList ["txids"] (\r -> GetTxs <$> need r) (handleTxs st), plain ["txids"] (\r -> GetTxsRaw <$> need r) (handleTxsRaw st),- marshalledList [] (\r -> GetTxsBlock <$> cap r) (handleTxsBlock st),- plain [] (\r -> GetTxsBlockRaw <$> cap r) (handleTxsBlockRaw st),+ marshalledPieces (.txBlock) [] (\r -> GetTxsBlock <$> cap r) (handleTxsBlock st),+ pieces (.txBlockRaw) [] (\r -> GetTxsBlockRaw <$> cap r) (handleTxsBlockRaw st), plain [] (\r -> GetTxAfter <$> cap r <*> cap r) (handleTxAfter st), plainList ("addresses" : limits) (\r -> GetAddrsTxs <$> need r <*> lim r) (handleAddrsTxs st),- marshalledList limits (\r -> GetAddrTxsFull <$> cap r <*> lim r) (handleAddrTxsFull st),- marshalledList ("addresses" : limits) (\r -> GetAddrsTxsFull <$> need r <*> lim r) (handleAddrsTxsFull st),+ marshalledPieces (.addressTxFull) limits (\r -> GetAddrTxsFull <$> cap r <*> lim r) (handleAddrTxsFull st),+ marshalledPieces+ (.addressTxFull)+ ("addresses" : limits)+ (\r -> GetAddrsTxsFull <$> need r <*> lim r)+ (handleAddrsTxsFull st), marshalledList ["addresses"] (\r -> GetAddrsBalance <$> need r) (handleAddrsBalance st), marshalledList ("addresses" : limits) (\r -> GetAddrsUnspent <$> need r <*> lim r) (handleAddrsUnspent st),- get "/events" ("pretty" : "after" : eventParams) (handleEvents st),+ get "/events" ("after" : eventParams) (handleEvents st), get "/dbstats" [] (handleDbStats st), -- the reference of the API, as a page and as the file that it shows get "/" [] (\_ -> file "text/html; charset=utf-8" swaggerPage),@@ -1100,19 +1093,31 @@ -- network, as a list of those, or in plain JSON marshalled :: (ApiResource a b, MarshalJSON Network b) => [Text] -> (Req -> IO a) -> (a -> IO b) -> Route- marshalled ps p h = pathCompact st ps p h (marshalEncoding net) (marshalValue net)+ marshalled ps p h = pathCompact ps p h (marshalEncoding net) marshalledList :: (ApiResource a (SerialList b), MarshalJSON Network b) => [Text] -> (Req -> IO a) -> (a -> IO [b]) -> Route marshalledList ps p h =- pathCompact- st- ps- p- (fmap SerialList . h)- (list (marshalEncoding net) . (.get))- (toJSONList . map (marshalValue net) . (.get))+ pathCompact ps p (fmap SerialList . h) (list (marshalEncoding net) . (.get))+ -- routes of what is answered while it is read: a list of items in+ -- the JSON of the network, or pieces that the handler made+ marshalledPieces ::+ (ApiResource a (SerialList b), MarshalJSON Network b) =>+ (WebMetrics -> StatTiming) ->+ [Text] ->+ (Req -> IO a) ->+ (a -> IO [IO [b]]) ->+ Route+ marshalledPieces df ps p h = pieces df ps p (listPieces (marshalEncoding net) <=< h)+ pieces ::+ (ApiResource a b) =>+ (WebMetrics -> StatTiming) ->+ [Text] ->+ (Req -> IO a) ->+ (a -> IO [IO Builder]) ->+ Route+ pieces = pathPieces st plain :: (ApiResource a b, ToJSON b) => [Text] -> (Req -> IO a) -> (a -> IO b) -> Route- plain ps p h = pathCompact st ps p h toEncoding toJSON+ plain ps p h = pathCompact ps p h toEncoding plainList :: (ApiResource a (SerialList b), ToJSON b) => [Text] -> (Req -> IO a) -> (a -> IO [b]) -> Route plainList ps p h = plain ps p (fmap SerialList . h)@@ -1122,7 +1127,8 @@ ("derive" : "nocache" : limits) (\r -> GetXPubTxs <$> cap r <*> dflt r <*> lim r <*> dflt r) (handleXPubTxs st),- marshalledList+ marshalledPieces+ (.xpubTxFull) ("derive" : "nocache" : limits) (\r -> GetXPubTxsFull <$> cap r <*> dflt r <*> lim r <*> dflt r) (handleXPubTxsFull st),@@ -1186,44 +1192,51 @@ json "json" = Just () json _ = Nothing --- | Register a handler for an API resource, with compact JSON by default.-pathCompact ::- (ApiResource a b) =>- WebState ->- [Text] ->- (Req -> IO a) ->- (a -> IO b) ->- (b -> Encoding) ->- (b -> Value) ->- Route-pathCompact st ps parser action encJson encValue =- pathCommon st ps parser action (const status200) encJson encValue False- -- | The route of an API resource: parse the request, run the handler, and--- encode the response as JSON. It accepts the parameters given, and--- @pretty@.-pathCommon ::+-- encode the response as JSON.+pathCompact :: (ApiResource a b) => [Text] -> (Req -> IO a) -> (a -> IO b) -> (b -> Encoding) -> Route+pathCompact ps parser action encJson =+ route (renderStdMethod (resourceMethod proxy)) (capturePath proxy) ps $ \req -> do+ res <- action =<< parser req+ return $ responseLBS status200 jsonType (encodingToLazyByteString (encJson res))+ where+ toProxy :: (Req -> IO a) -> Proxy a+ toProxy = const Proxy+ proxy = toProxy parser++-- | The route of an API resource that is answered while it is read, as+-- "Haskoin.Store.Web.Pieces" explains: the handler gives the bytes of the+-- response in pieces.+pathPieces :: (ApiResource a b) => WebState ->+ (WebMetrics -> StatTiming) -> [Text] -> (Req -> IO a) ->- (a -> IO b) ->- (b -> Status) ->- (b -> Encoding) ->- (b -> Value) ->- Bool ->+ (a -> IO [IO Builder]) -> Route-pathCommon _ ps parser action status encJson encValue pretty =- route (renderStdMethod (resourceMethod proxy)) (capturePath proxy) ("pretty" : ps) $ \req -> do- proto <- serialAs req pretty- res <- action =<< parser req- return $- responseLBS (status res) [(hContentType, "application/json")] (protoSerial proto encJson encValue res)+pathPieces st df ps parser action =+ route (renderStdMethod (resourceMethod proxy)) (capturePath proxy) ps $ \req ->+ inPieces st df jsonType (action =<< parser req) where toProxy :: (Req -> IO a) -> Proxy a toProxy = const Proxy proxy = toProxy parser +-- | A response in pieces, timed. The timing counts the whole response, the+-- time that the client takes to read it included.+inPieces :: WebState -> (WebMetrics -> StatTiming) -> ResponseHeaders -> IO [IO Builder] -> IO Response+inPieces st df headers pieces = do+ began <- now+ let done = forM_ st.metrics $ \m -> now >>= \ended -> addTiming (df m) (ended - began)+ (pieces >>= piecesResponse headers done) `onException` done+ where+ now = round . (* 1000) <$> getPOSIXTime :: IO Int++-- | The headers of a response in JSON.+jsonType :: ResponseHeaders+jsonType = [(hContentType, "application/json")]+ -- | Respond with JSON. streamEncoding :: Encoding -> IO Response streamEncoding e =@@ -1236,24 +1249,6 @@ return $ responseLBS status200 [(hContentType, "text/plain; charset=utf-8")] (TL.encodeUtf8 t) --- | Encode a response in JSON or pretty JSON.-protoSerial ::- SerialAs ->- (a -> Encoding) ->- (a -> Value) ->- a ->- L.ByteString-protoSerial SerialAsJSON f _ = encodingToLazyByteString . f-protoSerial SerialAsPrettyJSON _ g =- encodePretty' defConfig {confTrailingNewline = True} . g---- | The encoding that a request asks for: JSON, pretty if the @pretty@--- parameter or the default says so.-serialAs :: Req -> Bool -> IO SerialAs-serialAs req pretty = do- p <- paramOr req readBool "pretty" pretty- return $ if p then SerialAsPrettyJSON else SerialAsJSON- -- GET Block / GET Blocks -- -- | Handler for @GET \/block\/:block@: a block by hash.@@ -1294,28 +1289,34 @@ -- GET BlockRaw -- -- | Handler for @GET \/block\/:block\/raw@: a block by hash, serialized as in the peer-to-peer protocol.-handleBlockRaw ::- WebState ->- GetBlockRaw ->- IO (RawResult H.Block)-handleBlockRaw st (GetBlockRaw h) =- withMetrics st (.blockRaw) $- RawResult <$> getRawBlock st h+handleBlockRaw :: WebState -> GetBlockRaw -> IO [IO Builder]+handleBlockRaw st (GetBlockRaw h) = rawResult <$> getRawBlock st h --- | Block by hash with all its transactions. Responds with an error if not found.-getRawBlock ::- WebState ->- H.BlockHash ->- IO H.Block+-- | The pieces of a block by hash, serialized, in hexadecimal. Responds+-- with an error if not found.+getRawBlock :: WebState -> H.BlockHash -> IO [IO Builder] getRawBlock st h =- st.query.getBlock h >>= maybe (raise st ThingNotFound) return >>= toRawBlock st.query+ st.query.getBlock h >>= maybe (raise st ThingNotFound) (return . rawBlock st.query) --- | Rebuild a block from its data and its transactions.-toRawBlock :: StoreRead -> BlockData -> IO H.Block-toRawBlock q b = do- txs <- map transactionData . catMaybes <$> C.getTransactions q b.txs- return H.Block {header = b.header, txs}+-- | The pieces of a block serialized as in the peer-to-peer protocol, in+-- hexadecimal: its header and the number of its transactions, then its+-- transactions as they are read. The first piece has transactions too, so+-- that a response does not begin before something of them was read.+rawBlock :: StoreRead -> BlockData -> [IO Builder]+rawBlock q b =+ around (hexOf b.header <> hexOf (VarInt (fromIntegral (length b.txs)))) mempty $+ pieced pieceSize (fmap (foldMap (hexOf . transactionData) . catMaybes) . C.getTransactions q) b.txs +-- | The pieces of the JSON of a 'RawResult', from those of the hexadecimal.+rawResult :: [IO Builder] -> [IO Builder]+rawResult = around "{\"result\":\"" "\"}"++-- | The pieces of the JSON of a 'RawResultList', from those of the+-- hexadecimal of each of its items.+rawResultList :: [[IO Builder]] -> [IO Builder]+rawResultList items =+ around "[" "]" (concat [around (comma <> "\"") "\"" item | (comma, item) <- zip ("" : repeat ",") items])+ -- GET BlockBest / BlockBestRaw -- -- | Handler for @GET \/block\/best@: the best block.@@ -1328,15 +1329,11 @@ (bestBlock st.query) >>= maybe (raise st ThingNotFound) (return . pruneTx notx) -- | Handler for @GET \/block\/best\/raw@: the best block, serialized.-handleBlockBestRaw ::- WebState ->- GetBlockBestRaw ->- IO (RawResult H.Block)+handleBlockBestRaw :: WebState -> GetBlockBestRaw -> IO [IO Builder] handleBlockBestRaw st _ =- withMetrics st (.blockRaw) $- st.query.getBestBlock >>= \case- Nothing -> raise st ThingNotFound- Just h -> RawResult <$> getRawBlock st h+ st.query.getBestBlock >>= \case+ Nothing -> raise st ThingNotFound+ Just h -> rawResult <$> getRawBlock st h -- GET BlockLatest -- @@ -1378,14 +1375,10 @@ >>= (\hs -> getBlocks st hs notx) . concat -- | Handler for @GET \/block\/height\/:height\/raw@: the blocks at a height, serialized.-handleBlockHeightRaw ::- WebState ->- GetBlockHeightRaw ->- IO (RawResultList H.Block)+handleBlockHeightRaw :: WebState -> GetBlockHeightRaw -> IO [IO Builder] handleBlockHeightRaw st (GetBlockHeightRaw h) =- withMetrics st (.blockRaw) $- fmap RawResultList $- mapM (getRawBlock st) =<< st.query.getBlocksAtHeight (fromIntegral h)+ fmap rawResultList $+ mapM (getRawBlock st) =<< st.query.getBlocksAtHeight (fromIntegral h) -- GET BlockTime / BlockTimeRaw -- @@ -1414,29 +1407,19 @@ Just b -> return $ pruneTx notx b -- | Handler for @GET \/block\/time\/:time\/raw@: the last block with a timestamp at or before a time, serialized.-handleBlockTimeRaw ::- WebState ->- GetBlockTimeRaw ->- IO (RawResult H.Block)+handleBlockTimeRaw :: WebState -> GetBlockTimeRaw -> IO [IO Builder] handleBlockTimeRaw st (GetBlockTimeRaw (TimeParam t)) =- withMetrics st (.blockRaw) $ do- let ch = st.config.store.chain- C.blockAtOrBefore st.query ch t >>= \case- Nothing -> raise st ThingNotFound- Just b -> RawResult <$> (toRawBlock st.query b)+ C.blockAtOrBefore st.query st.config.store.chain t >>= \case+ Nothing -> raise st ThingNotFound+ Just b -> return (rawResult (rawBlock st.query b)) -- | Handler for @GET \/block\/mtp\/:time\/raw@: the first block with a median time -- past at or after a time, serialized.-handleBlockMTPRaw ::- WebState ->- GetBlockMTPRaw ->- IO (RawResult H.Block)+handleBlockMTPRaw :: WebState -> GetBlockMTPRaw -> IO [IO Builder] handleBlockMTPRaw st (GetBlockMTPRaw (TimeParam t)) =- withMetrics st (.blockRaw) $ do- let ch = st.config.store.chain- C.blockAtOrAfterMTP st.query ch t >>= \case- Nothing -> raise st ThingNotFound- Just b -> RawResult <$> (toRawBlock st.query b)+ C.blockAtOrAfterMTP st.query st.config.store.chain t >>= \case+ Nothing -> raise st ThingNotFound+ Just b -> return (rawResult (rawBlock st.query b)) -- GET Transactions -- @@ -1477,32 +1460,21 @@ RawResultList . map transactionData . catMaybes <$> C.getTransactions st.query (nub txids) --- | Transactions of a block. Responds with an error if not found.-getTxsBlock ::- WebState ->- H.BlockHash ->- IO [Transaction]-getTxsBlock st h =- st.query.getBlock h >>= \case- Nothing -> raise st ThingNotFound- Just b -> catMaybes <$> C.getTransactions st.query b.txs+-- | The hashes of the transactions of a block. Responds with an error if+-- not found.+getTxsBlock :: WebState -> H.BlockHash -> IO [TxHash]+getTxsBlock st h = st.query.getBlock h >>= maybe (raise st ThingNotFound) (return . (.txs)) --- | Handler for @GET \/transactions\/block\/:block@: the transactions of a block.-handleTxsBlock ::- WebState ->- GetTxsBlock ->- IO [Transaction]-handleTxsBlock st (GetTxsBlock h) =- withMetrics st (.txBlock) $ getTxsBlock st h+-- | Handler for @GET \/transactions\/block\/:block@: the transactions of a block, in pieces.+handleTxsBlock :: WebState -> GetTxsBlock -> IO [IO [Transaction]]+handleTxsBlock st (GetTxsBlock h) = transactionPieces st.query <$> getTxsBlock st h --- | Handler for @GET \/transactions\/block\/:block\/raw@: the transactions of a block, serialized.-handleTxsBlockRaw ::- WebState ->- GetTxsBlockRaw ->- IO (RawResultList Tx)+-- | Handler for @GET \/transactions\/block\/:block\/raw@: the transactions of a block, serialized, in pieces.+handleTxsBlockRaw :: WebState -> GetTxsBlockRaw -> IO [IO Builder] handleTxsBlockRaw st (GetTxsBlockRaw h) =- withMetrics st (.txBlockRaw) $- RawResultList . map transactionData <$> getTxsBlock st h+ listPieces hex . transactionPieces st.query =<< getTxsBlock st h+ where+ hex t = unsafeToEncoding ("\"" <> hexOf (transactionData t) <> "\"") -- GET TransactionAfterHeight -- @@ -1784,7 +1756,6 @@ -- @after@ takes up from an event ('eventsStart'). handleEvents :: WebState -> Req -> IO Response handleEvents st req = do- proto <- serialAs req False let asked name = lookup name req.params (start, watch) <- eventsOpen st asked >>= either (raise st) return return . responseStream status200 [(hContentType, "application/json")] $ \write flush' ->@@ -1796,15 +1767,11 @@ Just entries -> do forM_ entries $ \e -> do wanted <- atomically (stateTVar watch (relevant own.ctx st.query.maxGap e.seen))- when wanted (write (serial proto e.event))+ when wanted (write (serial e.event)) send (from + fromIntegral (length entries)) in withGaugeIncrease st (.events) (send start) where- serial proto e =- lazyByteString $- protoSerial proto toEncoding toJSON e <> newLine proto- newLine SerialAsJSON = "\n"- newLine SerialAsPrettyJSON = mempty+ serial e = fromEncoding (toEncoding e) <> "\n" own = st.config.store -- | Where a client of the events starts reading the log, and what it hears@@ -1944,26 +1911,41 @@ withMetrics st (.addressTx) $ st.query.getAddressesTxs addrs =<< paramToLimits st False pLimits --- | Handler for @GET \/address\/:address\/transactions\/full@: full transactions of an address.+-- | Handler for @GET \/address\/:address\/transactions\/full@: full transactions of an address, in the pieces+-- of 'pathPieces'. Which transactions they are is read at once; their+-- bodies are read piece by piece. handleAddrTxsFull :: WebState -> GetAddrTxsFull ->- IO [Transaction]-handleAddrTxsFull st (GetAddrTxsFull addr pLimits) =- withMetrics st (.addressTxFull) $ do- txs <- st.query.getAddressTxs addr =<< paramToLimits st True pLimits- catMaybes <$> C.getTransactions st.query (map (.txid) txs)+ IO [IO [Transaction]]+handleAddrTxsFull st (GetAddrTxsFull addr pLimits) = do+ txs <- st.query.getAddressTxs addr =<< paramToLimits st True pLimits+ return (transactionPieces st.query (map (.txid) txs)) --- | Handler for @GET \/address\/transactions\/full?addresses=…@: full transactions of several addresses.+-- | Handler for @GET \/address\/transactions\/full?addresses=…@: full transactions of several addresses, in+-- the pieces of 'pathPieces'. handleAddrsTxsFull :: WebState -> GetAddrsTxsFull ->- IO [Transaction]-handleAddrsTxsFull st (GetAddrsTxsFull addrs pLimits) =- withMetrics st (.addressTxFull) $ do- txs <- st.query.getAddressesTxs addrs =<< paramToLimits st True pLimits- catMaybes <$> C.getTransactions st.query (map (.txid) txs)+ IO [IO [Transaction]]+handleAddrsTxsFull st (GetAddrsTxsFull addrs pLimits) = do+ txs <- st.query.getAddressesTxs addrs =<< paramToLimits st True pLimits+ return (transactionPieces st.query (map (.txid) txs)) +-- | Transactions by their hashes, in pieces of 'pieceSize' that are each+-- read with one multi-get. The hashes are those that the database gave,+-- of a block or of addresses, so the transactions are there; one that is+-- gone by the time its piece is read is left out, as it is when the list+-- is read at once.+transactionPieces :: StoreRead -> [TxHash] -> [IO [Transaction]]+transactionPieces q = pieced pieceSize (fmap catMaybes . C.getTransactions q)++-- | Transactions in a piece of a list answered piece by piece. With 20 the+-- first byte leaves a millisecond or two sooner and with 500 some ten+-- later; the time of the whole response is the same with all three.+pieceSize :: Int+pieceSize = 100+ -- | Handler for @GET \/address\/:address\/balance@: balance of an address. handleAddrBalance :: WebState -> GetAddrBalance -> IO Balance handleAddrBalance st (GetAddrBalance addr) =@@ -2089,16 +2071,11 @@ withMetrics st (.xpubTx) $ getXPubTxs st xpub deriv plimits nocache --- | Handler for @GET \/xpub\/:xpub\/transactions\/full@: full transactions of an extended public key.-handleXPubTxsFull ::- WebState ->- GetXPubTxsFull ->- IO [Transaction]+-- | Handler for @GET \/xpub\/:xpub\/transactions\/full@: full transactions of an extended public key, in pieces.+handleXPubTxsFull :: WebState -> GetXPubTxsFull -> IO [IO [Transaction]] handleXPubTxsFull st (GetXPubTxsFull xpub deriv plimits (NoCache nocache)) =- withMetrics st (.xpubTxFull) $- fmap catMaybes $- C.getTransactions (cacheOr nocache st).query . map (.txid)- =<< getXPubTxs st xpub deriv plimits nocache+ transactionPieces (cacheOr nocache st).query . map (.txid)+ <$> getXPubTxs st xpub deriv plimits nocache -- | Handler for @GET \/xpub\/:xpub\/balances@: balances of the used addresses of an extended public key. handleXPubBalances ::@@ -2983,26 +2960,70 @@ format "json" = Just False format _ = Nothing --- | Handler for @GET \/blockchain\/block-height\/:height@: the blocks at a height, as Blockchain.info.+-- | Handler for @GET \/blockchain\/block-height\/:height@: the blocks at a height, as Blockchain.info, in+-- pieces. handleBinfoBlockHeight :: WebState -> Req -> IO Response handleBinfoBlockHeight st req =- withMetrics st (.binfoBlockHeight) $ do+ inPieces st (.binfoBlockHeight) binfoType $ do numtxid <- getNumTxId req height <- captureWith req readNum "height" bs <- fmap catMaybes $ st.query.getBlocksAtHeight height >>= mapM (st.query.getBlock)- ns <- fmap catMaybes $ st.query.getBlocksAtHeight (height + 1) >>= mapM (st.query.getBlock)- is <- mapM (get_binfo_blocks numtxid ns) bs- let net = st.config.store.net- let ctx = st.config.store.ctx- streamEncoding $ marshalEncoding (net, ctx) is+ blocks <- mapM (binfoBlockPieces st numtxid) bs+ return . around "{\"blocks\":[" "]}" $+ concat [around comma mempty block | (comma, block) <- zip ("" : repeat ",") blocks]++-- | The pieces of a block as Blockchain.info, with its transactions as+-- they are read.+--+-- The block is encoded without its transactions, which are the last thing+-- in it, and they are put where the empty list was. Should the encoding of+-- haskoin-store-data come to end another way, the block is read and+-- encoded whole, as it was before.+binfoBlockPieces :: WebState -> Bool -> BlockData -> IO [IO Builder]+binfoBlockPieces st numtxid b = do+ nhs <- fmap catMaybes $ st.query.getBlocksAtHeight (b.height + 1) >>= mapM (st.query.getBlock)+ let h x = H.headerHash x.header+ nxt = [h n | n <- nhs, n.header.prev == h b]+ own = (net, ctx)+ txs = transactionPieces st.query b.txs+ -- as 'toBinfoBlock' makes it, with the number of the transactions+ -- that are not in it yet+ bare =+ BinfoBlock+ { hash = h b,+ version = b.header.version,+ prev = b.header.prev,+ merkle = b.header.merkle,+ timestamp = b.header.timestamp,+ bits = b.header.bits,+ next = nxt,+ fee = b.fee,+ nonce = b.header.nonce,+ ntx = fromIntegral (length b.txs),+ size = b.size,+ index = b.height,+ main = b.main,+ height = b.height,+ weight = b.weight,+ txs = []+ }+ bytes = encodingToLazyByteString (marshalEncoding own bare)+ (before, after) = L.splitAt (L.length bytes - 3) bytes+ if after == "[]}"+ then+ around (lazyByteString before) "}"+ <$> listPieces (marshalEncoding own . toBinfoTxSimple numtxid) txs+ else do+ whole <- map (toBinfoTxSimple numtxid) . concat <$> sequence txs+ return [return (fromEncoding (marshalEncoding own (toBinfoBlock b whole nxt)))] where- get_binfo_blocks numtxid ns b = do- txs <- catMaybes <$> C.getTransactions st.query b.txs- let h x = H.headerHash x.header- nbs = [h n | n <- ns, n.header.prev == h b]- bts = map (toBinfoTxSimple numtxid) txs- return $ toBinfoBlock b bts nbs+ net = st.config.store.net+ ctx = st.config.store.ctx +-- | The headers of a response in JSON of the Blockchain.info endpoints.+binfoType :: ResponseHeaders+binfoType = [(hContentType, "application/json; charset=utf-8")]+ -- | Handler for @GET \/blockchain\/latestblock@: the best block, as Blockchain.info. handleBinfoLatest :: WebState -> Req -> IO Response handleBinfoLatest st req =@@ -3019,35 +3040,20 @@ txids = map (encodeBinfoTxId numtxid) b.txs } --- | Handler for @GET \/blockchain\/rawblock\/:block@: a block with its transactions, as Blockchain.info.+-- | Handler for @GET \/blockchain\/rawblock\/:block@: a block with its transactions, as Blockchain.info, in+-- pieces. handleBinfoBlock :: WebState -> Req -> IO Response-handleBinfoBlock st req =- withMetrics st (.binfoBlockRaw) $ do- numtxid <- getNumTxId req- hex <- getBinfoHex req- captureWith req parseBinfoBlockId "block" >>= \case- BinfoBlockHash bh -> go numtxid hex bh- BinfoBlockIndex i ->- st.query.getBlocksAtHeight i >>= \case- [] -> raise st ThingNotFound- bh : _ -> go numtxid hex bh- where- go numtxid hex bh = do- b <- maybe (raise st ThingNotFound) return =<< st.query.getBlock bh- txs <- catMaybes <$> C.getTransactions st.query b.txs- nhs <- fmap catMaybes $ st.query.getBlocksAtHeight (b.height + 1) >>= mapM (st.query.getBlock)- let h x = H.headerHash x.header- nxt = [h n | n <- nhs, n.header.prev == h b]- if hex- then do- let x = H.Block b.header (map transactionData txs)- textResponse . encodeHexLazy . runPutL $ serialize x- else do- let bts = map (toBinfoTxSimple numtxid) txs- y = toBinfoBlock b bts nxt- let net = st.config.store.net- let ctx = st.config.store.ctx- streamEncoding $ marshalEncoding (net, ctx) y+handleBinfoBlock st req = do+ numtxid <- getNumTxId req+ hex <- getBinfoHex req+ let kind = if hex then [(hContentType, "text/plain; charset=utf-8")] else binfoType+ inPieces st (.binfoBlockRaw) kind $ do+ bh <-+ captureWith req parseBinfoBlockId "block" >>= \case+ BinfoBlockHash bh -> return bh+ BinfoBlockIndex i -> st.query.getBlocksAtHeight i >>= maybe (raise st ThingNotFound) return . listToMaybe+ b <- maybe (raise st ThingNotFound) return =<< st.query.getBlock bh+ if hex then return (rawBlock st.query b) else binfoBlockPieces st numtxid b -- | Transaction by hash or short number. Fails with 'TxIndexConflict' if a short number matches several. getBinfoTx ::@@ -3356,15 +3362,14 @@ -- store fit to serve". pathHealth :: WebState -> Route pathHealth st =- route (renderStdMethod (resourceMethod proxy)) (capturePath proxy) ["pretty"] $ \req -> do- proto <- serialAs req False+ route (renderStdMethod (resourceMethod proxy)) (capturePath proxy) [] $ \_ -> do h <- handleHealth st GetHealth let (status, extra) | not (isOK h) = (status503, [("Retry-After", "5")]) | h.redis == Just False = (status203, [("Haskoin-Degraded", "redis")]) | otherwise = (status200, []) return $- responseLBS status ((hContentType, "application/json") : extra) (protoSerial proto toEncoding toJSON h)+ responseLBS status ((hContentType, "application/json") : extra) (encodingToLazyByteString (toEncoding h)) where proxy = Proxy :: Proxy GetHealth @@ -3690,9 +3695,14 @@ -- warning, with how long it took (0 for never). That is the one thing -- about a single request that says something of the server: a query that -- reads far more than it should, or a database that has become slow. The--- time is that of making the response, not of sending it, so a client on--- a slow line is not the server's slow request; and the stream of events,--- whose response never ends, is left out.+-- time runs until the last byte of the response is handed to the+-- connection. A long answer is sent while it is read+-- ("Haskoin.Store.Web.Pieces"), so the time that its status took to make+-- says little: the reads that matter come after it. The price is that a+-- client on a slow line, or a proxy that reads slowly, can make a request+-- slow too. A response cut short, by the client leaving or by a failure,+-- is logged with what it took until then. The stream of events, whose+-- response never ends, is left out. -- -- With the access log on, every request is logged as information instead -- of for debugging, with the address of the client and the time it took.@@ -3704,21 +3714,25 @@ logIt logger access slow app req respond = do start <- getPOSIXTime app req $ \res -> do- took <- subtract start <$> getPOSIXTime- let s = responseStatus res- msg = fmtReq req <> ": " <> fmtStatus s- seconds = cs (showFFloat (Just 1) (realToFrac took :: Double) "")- millis = cs (showFFloat (Just 1) (realToFrac took * 1000 :: Double) "")- client = case lookup "X-Forwarded-For" (requestHeaders req) of- Just given -> T.strip (T.takeWhile (/= ',') (T.decodeUtf8Lenient given))- Nothing -> cs (show (remoteHost req))- if- | statusIsServerError s && s /= status503 -> logError logger msg- | access -> logInfo logger (client <> " " <> msg <> ", " <> millis <> " ms")- | otherwise -> logDebug logger msg- when (slow > 0 && took >= fromIntegral slow && pathInfo req /= ["events"]) $- logWarn logger ("Slow request, " <> seconds <> " seconds: " <> msg)- respond res+ sent <- respond res `onException` report start res True+ report start res False+ return sent+ where+ report start res cut = do+ took <- subtract start <$> getPOSIXTime+ let s = responseStatus res+ msg = fmtReq req <> ": " <> fmtStatus s <> if cut then ", cut short" else ""+ seconds = cs (showFFloat (Just 1) (realToFrac took :: Double) "")+ millis = cs (showFFloat (Just 1) (realToFrac took * 1000 :: Double) "")+ client = case lookup "X-Forwarded-For" (requestHeaders req) of+ Just given -> T.strip (T.takeWhile (/= ',') (T.decodeUtf8Lenient given))+ Nothing -> cs (show (remoteHost req))+ if+ | statusIsServerError s && s /= status503 -> logError logger msg+ | access -> logInfo logger (client <> " " <> msg <> ", " <> millis <> " ms")+ | otherwise -> logDebug logger msg+ when (slow > 0 && took >= fromIntegral slow && pathInfo req /= ["events"]) $+ logWarn logger ("Slow request, " <> seconds <> " seconds: " <> msg) -- | What is wrong with a store whose health check fails, for its log. ailments :: HealthCheck -> Text
+ src/Haskoin/Store/Web/Pieces.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- |+-- Module : Haskoin.Store.Web.Pieces+-- Copyright : (c) Haskoin Developers+-- License : MIT+-- Maintainer : jprupp@protonmail.ch+-- Stability : experimental+-- Portability : POSIX+--+-- A response that is written while it is read.+--+-- A handler usually reads everything it answers with and then encodes it.+-- For a long list of large items, such as thousands of whole transactions,+-- that makes the client wait for the last item before it gets the first,+-- and makes the server hold the whole list for as long as the client takes+-- to read it. Here the list comes in pieces, each an action that reads some+-- of the items, and the response is written piece by piece.+--+-- = What it gives and what it does not+--+-- Measured on 5,000 transactions of one address, 15 MB of JSON: the first+-- byte left after 11 ms where it took 96 ms, and sixteen such requests at+-- once took 197 MB of memory where they took 1,014 MB. The whole response+-- took as long as before: most of that time goes into encoding JSON, which+-- this does not change. A short answer gains nothing, and should stay with+-- the routes that read first.+--+-- = Why it is safe+--+-- The order of things makes it so. All that can refuse the request, and the+-- first piece, come before the status line, so an error there is answered+-- as an error. A read that fails later can only cut the response short,+-- which a client sees as a response that does not end. So the pieces are+-- for what the database itself names, such as the transactions listed in a+-- block or under an address: those are there, and their reads are not+-- expected to fail. What the client names, such as a list of transaction+-- hashes, may not be there, and is read whole before anything is answered.+--+-- While a piece is written the next one is read, so that neither the+-- database nor the client waits for the other, and no more than two pieces+-- are held. Nothing of the database is held between pieces, so a slow+-- client costs two pieces of memory and no more. The price is that the+-- pieces are not read from one view of the database: an item may change,+-- or go, between two of them.+--+-- = The alternative+--+-- Lazy input and output, a lazy 'Data.ByteString.Lazy.ByteString' whose+-- chunks read the database when the server asks for them, would do the same+-- with less code. It was rejected: an error would come out of pure code,+-- and nothing would say when a read happens or ends.+module Haskoin.Store.Web.Pieces+ ( -- * Responses+ piecesResponse,++ -- * Pieces+ pieced,+ listPieces,+ around,+ hexOf,+ )+where++import Data.Aeson.Encoding (Encoding, fromEncoding)+import Data.ByteString.Builder (Builder, lazyByteStringHex)+import Data.Bytes.Put (runPutL)+import Data.Bytes.Serial (Serial (..))+import Data.IORef (newIORef, readIORef, writeIORef)+import Network.HTTP.Types (ResponseHeaders, status200)+import Network.Wai (Response, responseStream)+import UnliftIO (finally, wait, withAsync)++-- | The response made of pieces: the bytes of each, in order. A piece is+-- an action that reads something and gives its bytes. The first piece is+-- read before the response is made, and its errors are thrown here; the+-- others are read while the response is written, each while the one before+-- it is written. The action given runs when the response ends, however it+-- ends. The response has no @Content-Length@.+piecesResponse :: ResponseHeaders -> IO () -> [IO Builder] -> IO Response+piecesResponse headers done pieces = do+ (first, rest) <- case pieces of+ [] -> return (mempty, [])+ piece : more -> (,more) <$> piece+ return . responseStream status200 headers $ \write flush ->+ let send bytes [] = write bytes+ -- the thread that reads the next piece is let go before going on,+ -- or it would keep its piece until the end of the response+ send bytes (piece : more) = do+ bytes' <- withAsync piece $ \next -> write bytes >> flush >> wait next+ send bytes' more+ in send first rest `finally` done++-- | Cut a list of keys into pieces of a size, each read with the action+-- given: the pieces of items that are read by key.+pieced :: Int -> ([k] -> IO b) -> [k] -> [IO b]+pieced size fetch = map fetch . cut+ where+ cut [] = []+ cut ks = let (piece, more) = splitAt (max 1 size) ks in piece : cut more++-- | The pieces of a JSON array from pieces of its items: the same bytes as+-- the list of all the items encoded at once. A piece may have no items.+-- The pieces have to be run in order, as 'piecesResponse' runs them: each+-- has to know whether an item came before it, to put a comma.+listPieces :: (b -> Encoding) -> [IO [b]] -> IO [IO Builder]+listPieces enc pieces = do+ begun <- newIORef False+ let bytes piece = do+ items <- piece+ was <- readIORef begun+ writeIORef begun (was || not (null items))+ return . mconcat $+ [(if comma then "," else mempty) <> fromEncoding (enc item) | (comma, item) <- zip (was : repeat True) items]+ return (around "[" "]" (map bytes pieces))++-- | Pieces with bytes before the first and after the last, without a piece+-- more: the first piece stays the one that is read before the response.+around :: Builder -> Builder -> [IO Builder] -> [IO Builder]+around open close = \case+ [] -> [return (open <> close)]+ [only] -> [(\b -> open <> b <> close) <$> only]+ first : more -> ((open <>) <$> first) : ending more+ where+ ending [] = []+ ending [final] = [(<> close) <$> final]+ ending (piece : more) = piece : ending more++-- | The serialization of a value, in hexadecimal.+hexOf :: (Serial a) => a -> Builder+hexOf = lazyByteStringHex . runPutL . serialize
src/Haskoin/Store/Web/Publish.hs view
@@ -656,7 +656,8 @@ 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 (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.
swagger.yaml view
@@ -11,7 +11,7 @@ - url: './' info:- version: &version 1.11.0+ version: &version 1.12.0 title: Haskoin contact: name: JP Rupp@@ -90,8 +90,8 @@ ## Formats - - **JSON**, without spaces, to keep responses small.- - **Pretty JSON** with `pretty=true`, indented for people to read.+ - **JSON**, without spaces, to keep responses small. Pipe it through a+ tool such as `jq` to read it indented. Endpoints that end in `/raw` return data serialized as in the peer-to-peer protocol, in hexadecimal inside JSON (`{"result": "0100…"}`).@@ -257,6 +257,22 @@ `application/x-www-form-urlencoded`. A URL has room for some hundred addresses; a body has no such limit. `/transactions` is the exception: `POST` there publishes a transaction.+ - **Answers in pieces.** The endpoints that answer with all the+ transactions that the database lists somewhere send them while they+ read them, a hundred at a time, without a `Content-Length`: the first+ arrive while the server reads the last, and the server never holds the+ whole answer. They are the full transactions of addresses and of an+ xpub (`/address/{address}/transactions/full`,+ `/address/transactions/full`, `/xpub/{xpub}/transactions/full`), those+ of a block (`/transactions/block/{block}` and its `/raw`), the raw+ blocks (`/block/.../raw`), and the blocks of the Blockchain.info API+ (`/blockchain/rawblock/{block}`, `/blockchain/block-height/{height}`).+ What can refuse the request is checked before the first byte, so an+ error still comes with its status. Should the server fail after that,+ the response ends before it is complete: treat a response that does+ not end, or JSON that does not parse, as a failure and ask again.+ Lists that the client names itself, such as `/transactions?txids=`,+ are read whole first: what is asked for may not be there. - **`Vary: Accept-Encoding`** is on every answer, so that a cache keeps compressed and plain answers apart. - **`Retry-After`** is on a 503: one second from a server that is behind@@ -316,8 +332,6 @@ changed it), and this endpoint returns the latest result. It does no work of its own, so it is safe to call as often as a load balancer likes. operationId: healthCheck- parameters:- - $ref: '#/components/parameters/prettyParam' responses: '203': description: |@@ -421,7 +435,6 @@ - $ref: '#/components/parameters/heightParam' - $ref: '#/components/parameters/offsetParam' - $ref: '#/components/parameters/limitParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Transaction list starting with most recent.@@ -458,13 +471,14 @@ Full transactions are much larger, so the most that one call returns is lower (5,000, unless the operator changed it).++ It is sent while it is read (see "Answers in pieces" above). operationId: getAddressTxsFull parameters: - $ref: '#/components/parameters/addressParam' - $ref: '#/components/parameters/heightParam' - $ref: '#/components/parameters/offsetParam' - $ref: '#/components/parameters/limitParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Detailed transactions starting with most recent.@@ -575,7 +589,6 @@ - $ref: '#/components/parameters/heightParam' - $ref: '#/components/parameters/offsetParam' - $ref: '#/components/parameters/limitParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: List of transactions starting with most recent.@@ -623,7 +636,6 @@ - $ref: '#/components/parameters/heightParam' - $ref: '#/components/parameters/offsetParam' - $ref: '#/components/parameters/limitParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Detailed transactions starting with most recent.@@ -807,7 +819,6 @@ 404: every valid address exists, it just has not received anything yet. parameters: - $ref: '#/components/parameters/addressParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Address balance and other stats.@@ -840,7 +851,6 @@ operationId: getMultipleAddressBalances parameters: - $ref: '#/components/parameters/addressesParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Address balances and other stats.@@ -888,7 +898,6 @@ - $ref: '#/components/parameters/heightParam' - $ref: '#/components/parameters/offsetParam' - $ref: '#/components/parameters/limitParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: List of unspent outputs starting with most recent.@@ -952,7 +961,6 @@ - $ref: '#/components/parameters/heightParam' - $ref: '#/components/parameters/offsetParam' - $ref: '#/components/parameters/limitParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: List of unspent outputs starting with most recent.@@ -1024,7 +1032,6 @@ operationId: getBlockHead parameters: - $ref: '#/components/parameters/notxParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Best block data.@@ -1099,8 +1106,6 @@ The newest block, serialized as in the peer-to-peer protocol, with all its transactions. operationId: getRawBlockHead- parameters:- - $ref: '#/components/parameters/prettyParam' responses: '200': description: >-@@ -1135,7 +1140,6 @@ operationId: getLatestBlocks parameters: - $ref: '#/components/parameters/notxParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: List of most recent blocks.@@ -1209,7 +1213,6 @@ parameters: - $ref: '#/components/parameters/notxParam' - $ref: '#/components/parameters/blockParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Block data.@@ -1255,7 +1258,6 @@ its transactions. parameters: - $ref: '#/components/parameters/blockParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: >-@@ -1320,7 +1322,6 @@ parameters: - $ref: '#/components/parameters/notxParam' - $ref: '#/components/parameters/blocksParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: List of block data objects.@@ -1377,7 +1378,6 @@ parameters: - $ref: '#/components/parameters/blockHeightParam' - $ref: '#/components/parameters/notxParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Block data objects including orphans.@@ -1421,7 +1421,6 @@ The blocks at a height, serialized as in the peer-to-peer protocol. parameters: - $ref: '#/components/parameters/blockHeightParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: >-@@ -1464,7 +1463,6 @@ parameters: - $ref: '#/components/parameters/timeParam' - $ref: '#/components/parameters/notxParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Last block mined at or before specified time.@@ -1506,7 +1504,6 @@ Like `/block/time/{time}`, serialized as in the peer-to-peer protocol. parameters: - $ref: '#/components/parameters/timeParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: >-@@ -1554,7 +1551,6 @@ parameters: - $ref: '#/components/parameters/timeParam' - $ref: '#/components/parameters/notxParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Block at Median Time Past@@ -1596,7 +1592,6 @@ Like `/block/mtp/{time}`, serialized as in the peer-to-peer protocol. parameters: - $ref: '#/components/parameters/timeParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: >-@@ -1636,7 +1631,6 @@ parameters: - $ref: '#/components/parameters/blockHeightsParam' - $ref: '#/components/parameters/notxParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: List of block data objects at specified heights.@@ -1717,7 +1711,6 @@ the mempool, or whose block was abandoned, is not found. parameters: - $ref: '#/components/parameters/txidParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Detailed transaction object.@@ -1782,7 +1775,6 @@ send it. parameters: - $ref: '#/components/parameters/txidParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: >-@@ -1826,7 +1818,6 @@ parameters: - $ref: '#/components/parameters/txidParam' - $ref: '#/components/parameters/blockHeightParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: >-@@ -1862,7 +1853,6 @@ answered once. parameters: - $ref: '#/components/parameters/txidsParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: List of detailed transaction objects.@@ -1985,8 +1975,6 @@ 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' requestBody: description: >- Publish Transaction. The body holds one transaction and nothing@@ -2073,7 +2061,6 @@ The full transactions of a block, in the order of the block. parameters: - $ref: '#/components/parameters/blockParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Detailed transactions from specified Block.@@ -2251,7 +2238,6 @@ the order of the block. parameters: - $ref: '#/components/parameters/blockParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: >-@@ -2313,7 +2299,6 @@ that are not known are left out. parameters: - $ref: '#/components/parameters/txidsParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: >@@ -2362,7 +2347,6 @@ parameters: - $ref: '#/components/parameters/limitParam' - $ref: '#/components/parameters/offsetParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: List of transaction hashes from mempool.@@ -2384,7 +2368,6 @@ - Transaction operationId: getEventStream parameters:- - $ref: '#/components/parameters/prettyParam' - name: after in: query required: false@@ -2574,8 +2557,6 @@ tags: - Network operationId: getPeers- parameters:- - $ref: '#/components/parameters/prettyParam' summary: Connected Network Peers description: | The nodes of the peer-to-peer network that this server is connected to. It@@ -2625,7 +2606,6 @@ - $ref: '#/components/parameters/xpubParam' - $ref: '#/components/parameters/xpubDerive' - $ref: '#/components/parameters/nocacheParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Information about extended public key.@@ -2678,7 +2658,6 @@ parameters: - $ref: '#/components/parameters/xpubParam' - $ref: '#/components/parameters/xpubDerive'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: True if xpub got deleted from cache.@@ -2716,7 +2695,6 @@ - $ref: '#/components/parameters/limitParam' - $ref: '#/components/parameters/offsetParam' - $ref: '#/components/parameters/nocacheParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: List of transaction objects.@@ -2973,7 +2951,6 @@ - $ref: '#/components/parameters/limitParam' - $ref: '#/components/parameters/offsetParam' - $ref: '#/components/parameters/nocacheParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: List of transactions.@@ -3032,7 +3009,6 @@ - $ref: '#/components/parameters/xpubParam' - $ref: '#/components/parameters/xpubDerive' - $ref: '#/components/parameters/nocacheParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: Balances only for used addresses.@@ -3110,7 +3086,6 @@ - $ref: '#/components/parameters/limitParam' - $ref: '#/components/parameters/offsetParam' - $ref: '#/components/parameters/nocacheParam'- - $ref: '#/components/parameters/prettyParam' responses: '200': description: List of unspent output objects.@@ -7381,16 +7356,6 @@ type: string enum: [legacy, compat, segwit, normal] default: legacy-- prettyParam:- name: pretty- in: query- description: |- Indent the JSON, for people to read. Responses are compact by default to- save bandwidth.- required: false- schema:- type: boolean binfoAddr: name: address
test/Haskoin/Store/IntegrationSpec.hs view
@@ -209,6 +209,7 @@ 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 "answers in pieces what the database names, with what it would answer at once" piecesTest 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 it "drops a transaction double-spent in a reorganisation" reorgTest@@ -1064,6 +1065,63 @@ got <- getJSON env.plain (m <> "&n=10&offset=0") posted `shouldBe` got +-- | The endpoints that answer while they read ("Haskoin.Store.Web.Pieces"),+-- on a block and an address with more transactions than a piece has, so+-- that each answer is made of several: the bytes of a block are those that+-- the node gives, and the transactions are those that the endpoints of one+-- transaction give, all of them and in order.+piecesTest :: Env -> IO ()+piecesTest env = do+ let x = newXPub env "pieces" DeriveNormal+ a = at env x [0, 0]+ count = 130 :: Int+ replicateM_ count (rpc env.node "sendtoaddress" [String a, Number 0.0001])+ void $ mine env 1+ best <- bestBlockHash env.node+ height <- numV <$> rpc env.node "getblockcount" []+ hex <- rpc env.node "getblock" [String best, Number 0]+ ids <- maybe [] arr . field "tx" <$> plainJSON env ("/block/" <> cs best)+ -- what earlier tests left in the mempool is in the block too+ length ids `shouldSatisfy` (> count)+ -- raw blocks+ let block = "/block/" <> cs best+ forM_ [block <> "/raw", "/block/best/raw"] $ \p ->+ (field "result" <$> plainJSON env p) `shouldReturn` Just hex+ plainJSON env ("/block/height/" <> show height <> "/raw") `shouldReturn` toJSON [hex]+ text <- Wreq.get (env.plain <> "/blockchain/rawblock/" <> cs best <> "?format=hex")+ String (cs (text ^. Wreq.responseBody)) `shouldBe` hex+ lookup "Content-Length" (text ^. Wreq.responseHeaders) `shouldBe` Nothing+ -- the transactions of a block+ let one i = "/transaction/" <> cs (str i)+ str = \case+ String t -> t+ v -> error ("Not a string: " <> show v)+ singles <- mapM (plainJSON env . one) ids+ (arr <$> plainJSON env ("/transactions/block/" <> cs best)) `shouldReturn` singles+ raws <- map str . arr <$> plainJSON env ("/transactions/block/" <> cs best <> "/raw")+ length raws `shouldBe` length ids+ (T.concat raws `T.isSuffixOf` str hex) `shouldBe` True+ -- the block as Blockchain.info+ rb <- plainJSON env ("/blockchain/rawblock/" <> cs best)+ num "n_tx" rb `shouldBe` fromIntegral (length ids)+ map (field "hash") (maybe [] arr (field "tx" rb)) `shouldBe` map Just ids+ heights <- plainJSON env ("/blockchain/block-height/" <> show height)+ fmap arr (field "blocks" heights) `shouldBe` Just [rb]+ -- the transactions of addresses and of an xpub+ refs <- arr <$> plainJSON env ("/address/" <> cs a <> "/transactions?limit=200")+ length refs `shouldBe` count+ wanted <- mapM (plainJSON env . one) (mapMaybe (field "txid") refs)+ forM_+ [ "/address/" <> cs a <> "/transactions/full?limit=200",+ "/address/transactions/full?limit=200&addresses=" <> cs a,+ "/xpub/" <> x.text <> "/transactions/full?limit=200",+ "/xpub/" <> x.text <> "/transactions/full?limit=200&nocache=true"+ ]+ $ \p -> (arr <$> plainJSON env p) `shouldReturn` wanted+ -- a block that is not there is an error, not a response cut short+ (code, _) <- getJSON env.plain ("/transactions/block/" <> replicate 64 'a')+ code `shouldBe` 404+ -- | Endpoints that do not involve xpubs, checked against the node. endpointsTest :: Env -> IO () endpointsTest env = do@@ -1164,13 +1222,14 @@ let refused = [ ("/block/best?limt=5", "Unknown parameter: limt"), ("/block/best?notx=yes", "Invalid value for parameter notx: yes"),- ("/block/best?pretty=maybe", "Invalid value for parameter pretty"),+ ("/block/best?pretty=true", "Unknown parameter: pretty"),+ ("/health?pretty=true", "Unknown parameter: pretty"),+ ("/events?pretty=true", "Unknown parameter: pretty"), ("/mempool?limit=-1", "Invalid value for parameter limit"), ("/address/" <> cs a <> "/transactions?offset=x", "Invalid value for parameter offset"), ("/xpub/" <> x.text <> "?derive=Legacy", "Invalid value for parameter derive"), ("/blockchain/latestblock?txidindex=1", "Invalid value for parameter txidindex"), ("/blockchain/latestblock?format=hex", "Invalid value for parameter format"),- ("/blockchain/latestblock?pretty=true", "Unknown parameter: pretty"), ("/blockchain/rawtx/" <> cs coinbase <> "?format=xml", "Invalid value for parameter format"), ("/blockchain/multiaddr?active=" <> x.text <> "&filter=4", "Invalid value for parameter filter"), ("/blockchain/unspent?active=" <> cs a <> "&confirmations=-2", "Invalid value for parameter confirmations"),@@ -1184,7 +1243,7 @@ (code, v) <- postForm env.plain "/transactions" [("hex", "00")] (code, textField "message" v) `shouldBe` (400, Just "Unknown parameter: hex") forM_- [ "/block/best?notx=true&pretty=true",+ [ "/block/best?notx=true", "/blockchain/latestblock?format=json&txidindex=true", "/xpub/" <> x.text <> "?derive=normal&nocache=false" ]
+ test/Haskoin/Store/Web/PiecesSpec.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}++module Haskoin.Store.Web.PiecesSpec (spec) where++import Control.Exception (ErrorCall (..), throwIO, try)+import Data.Aeson (encode, toEncoding)+import Data.ByteString.Builder (Builder, toLazyByteString)+import Data.ByteString.Lazy qualified as L+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Haskoin.Store.Web.Pieces+import Network.Wai.Internal (Response (..))+import Test.Hspec hiding (around)++spec :: Spec+spec = describe "a response in pieces" $ do+ it "has the bytes of its pieces, in order" $ do+ answer [] `shouldReturn` ("", True)+ answer [return "a"] `shouldReturn` ("a", True)+ answer (map return ["a", "", "bc", "d"]) `shouldReturn` ("abcd", True)+ it "has the bytes of a list encoded at once, for pieces of its items" $ do+ let lists = [[], [[]], [[1]], [[1, 2], [3]], [[], [1], [], [2, 3], []], [[1 .. 100], [101 .. 150]]]+ listed :: [[Int]] -> IO (L.ByteString, Bool)+ listed l = listPieces toEncoding (map return l) >>= answer+ mapM_ (\l -> listed l `shouldReturn` (encode (concat l), True)) lists+ it "cuts keys into pieces of the size, and the last of what is left" $ do+ read' <- newIORef []+ let fetch ks = modifyIORef' read' (<> [ks]) >> return ks+ pieces <- listPieces toEncoding (pieced 3 fetch [1 .. 8 :: Int])+ answer pieces `shouldReturn` (encode [1 .. 8 :: Int], True)+ readIORef read' `shouldReturn` [[1, 2, 3], [4, 5, 6], [7, 8]]+ it "puts bytes around pieces without a piece more" $ do+ let wrapped ps = around "<" ">" (map return ps)+ let cases = [[], ["a"], ["a", "b"], ["a", "b", "c"]]+ mapM (fmap (toLazyByteString . mconcat) . sequence . wrapped) cases+ `shouldReturn` ["<>", "<a>", "<ab>", "<abc>"]+ map (length . wrapped) cases `shouldBe` [1, 1, 2, 3]+ it "throws what the first piece throws, before there is a response" $ do+ ended <- newIORef False+ r <- try (piecesResponse [] (mark ended) [broken, return "b"])+ either (\(ErrorCall e) -> e) (const "") r `shouldBe` "gone"+ it "ends short, and says that it ended, when a later piece throws" $ do+ ended <- newIORef False+ res <- piecesResponse [] (mark ended) [return "[1", broken]+ written <- newIORef mempty+ r <- try (body res (\b -> modifyIORef' written (<> b)) (return ()))+ either (\(ErrorCall e) -> e) (const "") r `shouldBe` "gone"+ (toLazyByteString <$> readIORef written) `shouldReturn` "[1"+ readIORef ended `shouldReturn` True+ it "reads one piece ahead of the one that it writes, and no further" $ do+ events <- newIORef []+ let note e = modifyIORef' events (<> [e])+ piece n = note ("read " <> show n) >> return mempty+ res <- piecesResponse [] (return ()) (map piece [1 .. 4 :: Int])+ body res (const (return ())) (note "flush")+ -- the next piece is read while one is written, so which of the two+ -- comes first is not fixed; what is fixed is that by the flush of a+ -- piece no piece past the next one has been asked for+ seen <- readIORef events+ filter (/= "flush") seen `shouldBe` ["read 1", "read 2", "read 3", "read 4"]+ let readsBy k = length (filter (/= "flush") (before k seen))+ before k = map fst . takeWhile ((< k) . snd) . (zip <*> flushes)+ flushes = scanl (\n e -> if e == "flush" then n + 1 else n) (0 :: Int)+ map readsBy [1, 2, 3] `shouldSatisfy` and . zipWith (>=) [2, 3, 4]+ where+ broken :: IO Builder+ broken = throwIO (ErrorCall "gone")+ mark :: IORef Bool -> IO ()+ mark ended = modifyIORef' ended (const True)+ body (ResponseStream _ _ run) = run+ body _ = \_ _ -> expectationFailure "not a stream"+ -- the bytes of the response, and whether it said that it ended+ answer :: [IO Builder] -> IO (L.ByteString, Bool)+ answer pieces = do+ ended <- newIORef False+ res <- piecesResponse [] (mark ended) pieces+ written <- newIORef mempty+ body res (\b -> modifyIORef' written (<> b)) (return ())+ (,) . toLazyByteString <$> readIORef written <*> readIORef ended
test/Haskoin/Store/WebSpec.hs view
@@ -1,6 +1,7 @@ module Haskoin.Store.WebSpec (spec) where import Control.Concurrent (threadDelay)+import Control.Exception (ErrorCall (..), throwIO, try) import Data.ByteString (ByteString) import Data.Either (isLeft) import Data.IORef (modifyIORef', newIORef, readIORef)@@ -49,7 +50,12 @@ -- | What the log has after a request that is answered with a status, after -- a number of milliseconds, by a server that warns of requests of a second. logged :: Bool -> [T.Text] -> Int -> Int -> IO [T.Text]-logged access path status wait = do+logged = loggedSending (return ())++-- | 'logged', with what sending the response does: wait, or fail as when+-- the client leaves.+loggedSending :: IO () -> Bool -> [T.Text] -> Int -> Int -> IO [T.Text]+loggedSending send access path status wait = do said <- newIORef [] let keep line = modifyIORef' said (decodeUtf8 (fromLogStr line) :) logger = Logger {level = LevelDebug, source = "", push = keep}@@ -59,7 +65,8 @@ 503 -> status503 _ -> status500 app _ respond = threadDelay (wait * 1000) >> respond (responseLBS answer [] "")- _ <- logIt logger access 1 app defaultRequest {pathInfo = path} (\_ -> return ResponseReceived)+ sending _ = send >> return ResponseReceived+ _ <- try @ErrorCall (logIt logger access 1 app defaultRequest {pathInfo = path} sending) reverse <$> readIORef said -- | The level of each line of a log, as the line names it at its start.@@ -94,6 +101,19 @@ levels slow `shouldBe` ["Debug", "Warn"] last slow `shouldSatisfy` T.isInfixOf "Slow request, 1.1 seconds: " levels <$> logged False ["events"] 200 1100 `shouldReturn` ["Debug"]+ it "counts the time of sending the response" $ do+ slow <- loggedSending (threadDelay 1100000) False ["block", "x", "raw"] 200 0+ levels slow `shouldBe` ["Debug", "Warn"]+ last slow `shouldSatisfy` T.isInfixOf "Slow request, 1.1 seconds: "+ it "logs a response cut short, and passes the failure on" $ do+ let leave = threadDelay 1100000 >> throwIO (ErrorCall "client left")+ cut <- loggedSending leave False ["block", "x", "raw"] 200 0+ levels cut `shouldBe` ["Debug", "Warn"]+ last cut `shouldSatisfy` T.isInfixOf "200 OK, cut short"+ let quiet = Logger {level = LevelError, source = "", push = \_ -> return ()}+ app _ respond = respond (responseLBS status200 [] "")+ sending _ = throwIO (ErrorCall "client left")+ logIt quiet False 1 app defaultRequest sending `shouldThrow` (== ErrorCall "client left") it "has every request as information when the access log is on" $ do lines' <- logged True ["block", "best"] 200 0 levels lines' `shouldBe` ["Info"]