diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,19 @@ 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) +## 0.47.4 +### Added +- Implement Blockchain.info block height. +- Implement Blockchain.info raw address. +- Implement Blockchain.info balances. + +### Fixed +- Make Blockchain.info unspent endpoint more efficient. +- Make Blockchain.info xpubs endpoint more efficient. + +### Changed +- Use compact JSON serialization by default everywhere. + ## 0.47.3 ### Fixed - Fix serialization bug with unspents. diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d755d5288e6cafa79a1b58ad901077e5d1c297d75a71bd7654b506751c772719 +-- hash: e71c4b84b22cfac8473981ce40d82ce5e538c083b247b7957818865889ce4541 name: haskoin-store -version: 0.47.3 +version: 0.47.4 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -61,7 +61,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 - , haskoin-store-data ==0.47.3 + , haskoin-store-data ==0.47.4 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -113,7 +113,7 @@ , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.47.3 + , haskoin-store-data ==0.47.4 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -170,7 +170,7 @@ , haskoin-core >=0.19.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.47.3 + , haskoin-store-data ==0.47.4 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -222,6 +222,10 @@ ask >>= \case Nothing -> lift (xPubTxs xpub limits) Just cfg -> lift (runReaderT (getXPubTxs xpub limits) cfg) + xPubTxCount xpub = + ask >>= \case + Nothing -> lift (xPubTxCount xpub) + Just cfg -> lift (runReaderT (getXPubTxCount xpub) cfg) getMaxGap = lift getMaxGap getInitialGap = lift getInitialGap getNumTxData = lift . getNumTxData @@ -241,73 +245,81 @@ getXPubTxs :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => XPubSpec -> Limits -> CacheX m [TxRef] -getXPubTxs xpub limits = do - xpubtxt <- xpubText xpub - isXPubCached xpub >>= \case +getXPubTxs xpub limits = go Nothing + where + go m = isXPubCached xpub >>= \case True -> do - incrementCounter cacheHits - txs <- cacheGetXPubTxs xpub limits - return txs - False -> do - bals <- lift $ xPubBals xpub - newXPubC xpub bals - lift $ xPubBalsTxs bals limits + when (isNothing m) $ incrementCounter cacheHits + cacheGetXPubTxs xpub limits + False -> + case m of + Just bals -> lift $ xPubBalsTxs bals limits + Nothing -> do + bals <- lift $ xPubBals xpub + newXPubC xpub bals + go (Just bals) +getXPubTxCount :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) + => XPubSpec -> CacheX m Word32 +getXPubTxCount xpub = go False + where + go t = isXPubCached xpub >>= \case + True -> do + unless t $ incrementCounter cacheHits + cacheGetXPubTxCount xpub + False -> + if t + then lift $ xPubTxCount xpub + else do + bals <- lift $ xPubBals xpub + newXPubC xpub bals + go True + getXPubUnspents :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => XPubSpec -> Limits -> CacheX m [XPubUnspent] -getXPubUnspents xpub limits = do - xpubtxt <- xpubText xpub - isXPubCached xpub >>= \case - True -> do - incrementCounter cacheHits - bals <- cacheGetXPubBalances xpub - process bals - False -> do - bals <- lift $ xPubBals xpub - newXPubC xpub bals - lift $ xPubBalsUnspents bals limits +getXPubUnspents xpub limits = go Nothing where + go m = isXPubCached xpub >>= \case + True -> do + when (isNothing m) $ incrementCounter cacheHits + process =<< cacheGetXPubBalances xpub + False -> case m of + Just bals -> lift $ xPubBalsUnspents bals limits + Nothing -> do + bals <- lift $ xPubBals xpub + newXPubC xpub bals + go (Just bals) process bals = do ops <- map snd <$> cacheGetXPubUnspents xpub limits uns <- catMaybes <$> lift (mapM getUnspent ops) - let addrmap = - Map.fromList $ - map (\b -> (balanceAddress (xPubBal b), xPubBalPath b)) bals - addrutxo = - mapMaybe - (\u -> - either - (const Nothing) - (\a -> Just (a, u)) - (scriptToAddressBS (unspentScript u))) - uns - xpubutxo = - mapMaybe - (\(a, u) -> (`XPubUnspent` u) <$> Map.lookup a addrmap) - addrutxo - xpubtxt <- xpubText xpub - return xpubutxo + let g b = (balanceAddress (xPubBal b), xPubBalPath b) + addrmap = Map.fromList (map g bals) + f u = either + (const Nothing) + (\a -> Just (a, u)) + (scriptToAddressBS (unspentScript u)) + addrutxo = mapMaybe f uns + e (a, u) = (`XPubUnspent` u) <$> Map.lookup a addrmap + return $ mapMaybe e addrutxo getXPubBalances :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) => XPubSpec -> CacheX m [XPubBal] -getXPubBalances xpub = do - xpubtxt <- xpubText xpub - isXPubCached xpub >>= \case - True -> do - incrementCounter cacheHits - cacheGetXPubBalances xpub - False -> do - bals <- lift $ xPubBals xpub - newXPubC xpub bals - return bals +getXPubBalances xpub = isXPubCached xpub >>= \case + True -> do + incrementCounter cacheHits + cacheGetXPubBalances xpub + False -> do + bals <- lift $ xPubBals xpub + newXPubC xpub bals + return bals isInCache :: MonadLoggerIO m => XPubSpec -> CacheT m Bool isInCache xpub = ask >>= \case - Nothing -> return False - Just cfg -> runReaderT (isXPubCached xpub) cfg + Nothing -> return False + Just cfg -> runReaderT (isXPubCached xpub) cfg isXPubCached :: MonadLoggerIO m => XPubSpec -> CacheX m Bool isXPubCached = runRedis . redisIsXPubCached @@ -321,6 +333,16 @@ touchKeys [xpub] return bals +cacheGetXPubTxCount :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadExtra m) + => XPubSpec -> CacheX m Word32 +cacheGetXPubTxCount xpub = do + count <- fromInteger <$> runRedis (redisGetXPubTxCount xpub) + touchKeys [xpub] + return count + +redisGetXPubTxCount :: RedisCtx m f => XPubSpec -> m (f Integer) +redisGetXPubTxCount xpub = Redis.zcard (txSetPfx <> encode xpub) + cacheGetXPubTxs :: (StoreReadBase m, MonadLoggerIO m) => XPubSpec @@ -355,16 +377,14 @@ -> Limits -> CacheX m [(BlockRef, OutPoint)] cacheGetXPubUnspents xpub limits = do - score <- - case start limits of - Nothing -> return Nothing - Just (AtTx th) -> - lift (getTxData th) >>= \case - Just TxData {txDataBlock = b@BlockRef {}} -> - return (Just (blockRefScore b)) - _ -> return Nothing - Just (AtBlock h) -> - return (Just (blockRefScore (BlockRef h maxBound))) + score <- case start limits of + Nothing -> return Nothing + Just (AtTx th) -> lift (getTxData th) >>= \case + Just TxData {txDataBlock = b@BlockRef {}} -> + return (Just (blockRefScore b)) + _ -> return Nothing + Just (AtBlock h) -> + return (Just (blockRefScore (BlockRef h maxBound))) xs <- runRedis $ getFromSortedSet @@ -881,7 +901,7 @@ getxbals xpubs = do bals <- runRedis . fmap sequence . forM xpubs $ \xpub -> do bs <- redisGetXPubBalances xpub - return $ (xpub, ) <$> bs + return $ (,) xpub <$> bs return $ HashMap.filter (not . null) (HashMap.fromList bals) allops = map snd $ concatMap txInputs txs <> concatMap txOutputs txs alladdrs = @@ -1258,7 +1278,11 @@ => XPubSpec -> CacheX m Text xpubText xpub = do net <- lift getNetwork - return . cs $ xPubExport net (xPubSpecKey xpub) + let suffix = case xPubDeriveType xpub of + DeriveNormal -> "" + DeriveP2SH -> "/p2sh" + DeriveP2WPKH -> "/p2wpkh" + return . cs $ suffix <> xPubExport net (xPubSpecKey xpub) cacheNewBlock :: MonadIO m => CacheWriter -> m () cacheNewBlock = send CacheNewBlock diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -81,12 +81,9 @@ type Offset = Word32 type Limit = Word32 -data Start = AtTx - { atTxHash :: !TxHash - } - | AtBlock - { atBlockHeight :: !BlockHeight - } +data Start + = AtTx{atTxHash :: !TxHash} + | AtBlock{atBlockHeight :: !BlockHeight} deriving (Eq, Show) data Limits = Limits @@ -191,6 +188,8 @@ bs <- xPubBals xpub let as = map (balanceAddress . xPubBal) bs getAddressesTxs as limits + xPubTxCount :: XPubSpec -> m Word32 + xPubTxCount xpub = fromIntegral . length <$> xPubTxs xpub def getMaxGap :: m Word32 getInitialGap :: m Word32 diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -688,14 +688,11 @@ go (last ls) where go x = - lift (f (Limits 50 0 (Just (AtTx (g x))))) >>= \case + lift (f (Limits 50 1 (Just (AtTx (g x))))) >>= \case [] -> return () ls -> do - case dropWhile ((== g x) . g) ls of - [] -> return () - ls' -> do - mapM yield ls' - go (last ls') + mapM yield ls + go (last ls) joinStreams :: Monad m => (a -> a -> Ordering) 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 @@ -18,12 +18,13 @@ ) where import Conduit (ConduitT, await, dropC, - runConduit, sinkList, takeC, - yield, (.|)) + dropWhileC, mapC, runConduit, + sinkList, takeC, yield, (.|)) import Control.Applicative ((<|>)) import Control.Arrow (second) import Control.Lens -import Control.Monad (forever, unless, when, (<=<)) +import Control.Monad (forM, forever, unless, when, + (<=<)) import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS, logInfoS) import Control.Monad.Reader (ReaderT, ask, asks, local, @@ -38,12 +39,12 @@ import Data.Aeson.Text (encodeToLazyText) import Data.ByteString.Builder (lazyByteString) import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Base16 as BL16 import qualified Data.ByteString.Lazy.Char8 as C import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial import Data.Char (isSpace) -import qualified Data.ByteString.Lazy.Base16 as BL16 import Data.Default (Default (..)) import Data.Function (on, (&)) import Data.HashMap.Strict (HashMap) @@ -199,6 +200,10 @@ , xPubUnspentResponseTime :: !StatDist , multiaddrResponseTime :: !StatDist , multiaddrErrors :: !ErrorCounter + , rawaddrResponseTime :: !StatDist + , rawaddrErrors :: !ErrorCounter + , balanceResponseTime :: !StatDist + , balanceErrors :: !ErrorCounter , unspentResponseTime :: !StatDist , unspentErrors :: !ErrorCounter , rawtxResponseTime :: !StatDist @@ -231,8 +236,12 @@ xPubTxResponseTime <- d "xpub_tx.response_time_ms" xPubTxFullResponseTime <- d "xpub_tx_full.response_time_ms" xPubUnspentResponseTime <- d "xpub_unspent.response_time_ms" + rawaddrResponseTime <- d "rawaddr.response_time_ms" + rawaddrErrors <- e "rawaddr.errors" multiaddrResponseTime <- d "multiaddr.response_time_ms" multiaddrErrors <- e "multiaddr.errors" + balanceResponseTime <- d "balance.response_time_ms" + balanceErrors <- e "balance.errors" rawtxResponseTime <- d "rawtx.response_time_ms" rawtxErrors <- e "rawtx.errors" peerResponseTime <- d "peer.response_time_ms" @@ -442,7 +451,7 @@ => S.ScottyT Except (ReaderT WebState m) () handlePaths = do -- Block Paths - pathPretty + pathCompact (GetBlock <$> paramLazy <*> paramDef) scottyBlock blockDataToEncoding @@ -457,7 +466,7 @@ scottyBlockRaw (const toEncoding) (const toJSON) - pathPretty + pathCompact (GetBlockBest <$> paramDef) scottyBlockBest blockDataToEncoding @@ -472,7 +481,7 @@ (fmap SerialList . scottyBlockLatest) (\n -> list (blockDataToEncoding n) . getSerialList) (\n -> json_list blockDataToJSON n . getSerialList) - pathPretty + pathCompact (GetBlockHeight <$> paramLazy <*> paramDef) (fmap SerialList . scottyBlockHeight) (\n -> list (blockDataToEncoding n) . getSerialList) @@ -487,7 +496,7 @@ scottyBlockHeightRaw (const toEncoding) (const toJSON) - pathPretty + pathCompact (GetBlockTime <$> paramLazy <*> paramDef) scottyBlockTime blockDataToEncoding @@ -497,7 +506,7 @@ scottyBlockTimeRaw (const toEncoding) (const toJSON) - pathPretty + pathCompact (GetBlockMTP <$> paramLazy <*> paramDef) scottyBlockMTP blockDataToEncoding @@ -508,7 +517,7 @@ (const toEncoding) (const toJSON) -- Transaction Paths - pathPretty + pathCompact (GetTx <$> paramLazy) scottyTx transactionToEncoding @@ -548,13 +557,13 @@ scottyPostTx (const toEncoding) (const toJSON) - pathPretty + pathCompact (GetMempool <$> paramOptional <*> parseOffset) (fmap SerialList . scottyMempool) (const toEncoding) (const toJSON) -- Address Paths - pathPretty + pathCompact (GetAddrTxs <$> paramLazy <*> parseLimits) (fmap SerialList . scottyAddrTxs) (const toEncoding) @@ -574,7 +583,7 @@ (fmap SerialList . scottyAddrsTxsFull) (\n -> list (transactionToEncoding n) . getSerialList) (\n -> json_list transactionToJSON n . getSerialList) - pathPretty + pathCompact (GetAddrBalance <$> paramLazy) scottyAddrBalance balanceToEncoding @@ -584,7 +593,7 @@ (fmap SerialList . scottyAddrsBalance) (\n -> list (balanceToEncoding n) . getSerialList) (\n -> json_list balanceToJSON n . getSerialList) - pathPretty + pathCompact (GetAddrUnspent <$> paramLazy <*> parseLimits) (fmap SerialList . scottyAddrUnspent) (\n -> list (unspentToEncoding n) . getSerialList) @@ -595,12 +604,12 @@ (\n -> list (unspentToEncoding n) . getSerialList) (\n -> json_list unspentToJSON n . getSerialList) -- XPubs - pathPretty + pathCompact (GetXPub <$> paramLazy <*> paramDef <*> paramDef) scottyXPub (const toEncoding) (const toJSON) - pathPretty + pathCompact (GetXPubTxs <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) (fmap SerialList . scottyXPubTxs) (const toEncoding) @@ -610,23 +619,23 @@ (fmap SerialList . scottyXPubTxsFull) (\n -> list (transactionToEncoding n) . getSerialList) (\n -> json_list transactionToJSON n . getSerialList) - pathPretty + pathCompact (GetXPubBalances <$> paramLazy <*> paramDef <*> paramDef) (fmap SerialList . scottyXPubBalances) (\n -> list (xPubBalToEncoding n) . getSerialList) (\n -> json_list xPubBalToJSON n . getSerialList) - pathPretty + pathCompact (GetXPubUnspent <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef) (fmap SerialList . scottyXPubUnspent) (\n -> list (xPubUnspentToEncoding n) . getSerialList) (\n -> json_list xPubUnspentToJSON n . getSerialList) -- Network - pathPretty + pathCompact (GetPeers & return) (fmap SerialList . scottyPeers) (const toEncoding) (const toJSON) - pathPretty + pathCompact (GetHealth & return) scottyHealth (const toEncoding) @@ -636,10 +645,14 @@ -- Blockchain.info S.post "/blockchain/multiaddr" scottyMultiAddr S.get "/blockchain/multiaddr" scottyMultiAddr + S.get "/blockchain/balance" scottyShortBal + S.post "/blockchain/balance" scottyShortBal + S.get "/blockchain/rawaddr/:addr" scottyRawAddr S.post "/blockchain/unspent" scottyBinfoUnspent S.get "/blockchain/unspent" scottyBinfoUnspent - S.get "/blockchain/rawtx/:txid" scottyBinfoTx - S.get "/blockchain/rawblock/:block" scottyBinfoBlock + S.get "/blockchain/rawtx/:txid" scottyBinfoTx + S.get "/blockchain/rawblock/:block" scottyBinfoBlock + S.get "/blockchain/block-height/:height" scottyBinfoBlockHeight where json_list f net = toJSONList . map (f net) @@ -770,7 +783,7 @@ unsafeInterleaveIO . run $ getTransaction x >>= \case Nothing -> undefined - Just t -> return $ transactionData t + Just t -> return $ transactionData t -- GET BlockBest / BlockBestRaw -- @@ -916,7 +929,7 @@ unsafeInterleaveIO . run $ getTransaction x >>= \case Nothing -> undefined - Just t -> return t + Just t -> return t scottyTxsBlock :: (MonadUnliftIO m, MonadLoggerIO m) => GetTxsBlock -> WebT m [Transaction] @@ -1253,6 +1266,10 @@ getNumTxId :: MonadIO m => WebT m Bool getNumTxId = fmap not $ S.param "txidindex" `S.rescue` const (return False) +getChainHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m H.BlockHeight +getChainHeight = + fmap H.nodeHeight $ chainGetBest =<< lift (asks (storeChain . webStore . webConfig)) + scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyBinfoUnspent = getBinfoActive unspentErrors >>= \(xspecs, addrs) -> @@ -1261,39 +1278,29 @@ get_min_conf >>= \min_conf -> let len = HashSet.size addrs + HashMap.size xspecs in withMetrics unspentResponseTime len $ do - xuns <- get_xpub_unspents xspecs - auns <- get_addr_unspents addrs net <- lift $ asks (storeNetwork . webStore . webConfig) - height <- get_height - let g k = map (xpub_unspent numtxid height k) - xbus = concatMap (uncurry g) (HashMap.toList xuns) - abus = map (unspent numtxid height) auns - f u@BinfoUnspent{..} = - ((getBinfoUnspentHash, getBinfoUnspentOutputIndex), u) - busm = HashMap.fromList (map f (xbus ++ abus)) - bus = - take limit $ - takeWhile ((min_conf <=) . getBinfoUnspentConfirmations) $ - sortBy - (flip compare `on` getBinfoUnspentConfirmations) - (HashMap.elems busm) + height <- getChainHeight + let mn BinfoUnspent{..} = min_conf > getBinfoUnspentConfirmations + xspecs' = HashSet.fromList $ HashMap.elems xspecs + bus <- lift . runConduit $ + getBinfoUnspents numtxid height xspecs' addrs .| + (dropWhileC mn >> takeC limit .| sinkList) setHeaders streamEncoding (binfoUnspentsToEncoding net (BinfoUnspents bus)) where get_limit = fmap (min 1000) $ S.param "limit" `S.rescue` const (return 250) get_min_conf = S.param "confirmations" `S.rescue` const (return 0) - get_height = - getBestBlock >>= \case - Nothing -> raise unspentErrors ThingNotFound - Just bh -> getBlock bh >>= \case - Nothing -> raise unspentErrors ThingNotFound - Just b -> return (blockDataHeight b) - xpub_unspent numtxid height xpub (XPubUnspent p u) = - let path = toSoft (listToPath p) - xp = BinfoXPubPath xpub <$> path - bu = unspent numtxid height u - in bu {getBinfoUnspentXPub = xp} - unspent numtxid height Unspent{..} = + +getBinfoUnspents :: (StoreReadExtra m, MonadIO m) + => Bool + -> H.BlockHeight + -> HashSet XPubSpec + -> HashSet Address + -> ConduitT () BinfoUnspent m () +getBinfoUnspents numtxid height xspecs addrs = + joinStreams (flip compare `on` fst) conduits .| mapC (uncurry binfo) + where + binfo Unspent{..} xp = let conf = case unspentBlock of MemRef{} -> 0 BlockRef h _ -> height - h + 1 @@ -1309,10 +1316,25 @@ , getBinfoUnspentValue = val , getBinfoUnspentConfirmations = fromIntegral conf , getBinfoUnspentTxIndex = txi - , getBinfoUnspentXPub = Nothing + , getBinfoUnspentXPub = xp } - get_xpub_unspents = mapM (`xPubUnspents` def) - get_addr_unspents = (`getAddressesUnspents` def) . HashSet.toList + point_hash = outPointHash . unspentPoint + conduits = xconduits <> acounduits + xconduits = + let f x (XPubUnspent p u) = + let path = toSoft (listToPath p) + xp = BinfoXPubPath (xPubSpecKey x) <$> path + in (u, xp) + g x = + streamThings (xPubUnspents x) (point_hash . xPubUnspent) def .| + mapC (f x) + in map g (HashSet.toList xspecs) + acounduits = + let f u = (u, Nothing) + g a = + streamThings (getAddressUnspents a) point_hash def .| + mapC f + in map g (HashSet.toList addrs) getBinfoTxs :: (StoreReadExtra m, MonadIO m) => HashMap Address (Maybe BinfoXPubPath) -- address book @@ -1387,7 +1409,7 @@ let len = HashSet.size addrs' + HashSet.size xpubs in withMetrics multiaddrResponseTime len $ do xbals <- get_xbals xspecs - xtxns <- mapM count_txs xspecs + xtxns <- mapM (fmap fromIntegral . xPubTxCount) xspecs let sxbals = subset sxpubs xbals xabals = compute_xabals xbals addrs = addrs' `HashSet.difference` HashMap.keysSet xabals @@ -1450,7 +1472,6 @@ , getBinfoMultiAddrCashAddr = cashaddr } where - count_txs xspec = length <$> xPubTxs xspec def get_filter = S.param "filter" `S.rescue` const (return BinfoFilterAll) get_best_block = getBestBlock >>= \case @@ -1557,11 +1578,126 @@ | otherwise = 0 received _ = 0 +scottyRawAddr :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyRawAddr = + get_addr >>= \addr -> + getNumTxId >>= \numtxid -> + get_offset >>= \off -> + get_count >>= \n -> + withMetrics rawaddrResponseTime 1 $ do + bal <- fromMaybe (zeroBalance addr) <$> getBalance addr + net <- lift $ asks (storeNetwork . webStore . webConfig) + let abook = HashMap.singleton addr Nothing + xspecs = HashSet.empty + saddrs = HashSet.singleton addr + bfilter = BinfoFilterAll + b = fromIntegral $ balanceAmount bal + balanceZero bal + txs <- lift . runConduit $ + getBinfoTxs abook xspecs saddrs saddrs bfilter numtxid False b .| + (dropC off >> takeC n .| sinkList) + setHeaders + streamEncoding $ binfoRawAddrToEncoding net $ BinfoRawAddr bal txs + where + get_addr = do + txt <- S.param "addr" + net <- lift $ asks (storeNetwork . webStore . webConfig) + case textToAddr net txt of + Nothing -> raise rawaddrErrors ThingNotFound + Just a -> return a + get_count = do + d <- lift (asks (maxLimitDefault . webMaxLimits . webConfig)) + x <- lift (asks (maxLimitFull . webMaxLimits . webConfig)) + i <- min x <$> (S.param "n" `S.rescue` const (return d)) + return $ fromIntegral i + get_offset = do + x <- lift (asks (maxLimitOffset . webMaxLimits . webConfig)) + o <- S.param "offset" `S.rescue` const (return 0) + when (o > x) $ + raise rawaddrErrors $ + UserError $ "offset exceeded: " <> show o <> " > " <> show x + return $ fromIntegral o + +scottyShortBal :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyShortBal = + getBinfoActive balanceErrors >>= \(xspecs, addrs) -> + getNumTxId >>= \numtxid -> + withMetrics balanceResponseTime (hl addrs + ml xspecs) $ do + net <- lift $ asks (storeNetwork . webStore . webConfig) + abals <- catMaybes <$> mapM (get_addr_balance net) (HashSet.toList addrs) + xbals <- mapM (get_xspec_balance net) (HashMap.elems xspecs) + let res = HashMap.fromList (abals <> xbals) + setHeaders + streamEncoding $ toEncoding res + where + hl = HashSet.size + ml = HashMap.size + to_short_bal Balance{..} = + BinfoShortBal + { + binfoShortBalFinal = balanceAmount + balanceZero, + binfoShortBalTxCount = balanceTxCount, + binfoShortBalReceived = balanceTotalReceived + } + get_addr_balance net a = + case addrToText net a of + Nothing -> return Nothing + Just a' -> getBalance a >>= \case + Nothing -> return $ Just (a', to_short_bal (zeroBalance a)) + Just b -> return $ Just (a', to_short_bal b) + is_ext XPubBal{xPubBalPath = 0:_} = True + is_ext _ = False + get_xspec_balance net xpub = do + xbals <- xPubBals xpub + xts <- xPubTxCount xpub + let val = sum $ map balanceAmount $ map xPubBal xbals + zro = sum $ map balanceZero $ map xPubBal xbals + exs = filter is_ext xbals + rcv = sum $ map balanceTotalReceived $ map xPubBal exs + sbl = + BinfoShortBal + { + binfoShortBalFinal = val + zro, + binfoShortBalTxCount = fromIntegral xts, + binfoShortBalReceived = rcv + } + return (xPubExport net (xPubSpecKey xpub), sbl) + getBinfoHex :: Monad m => WebT m Bool getBinfoHex = (== ("hex" :: Text)) <$> S.param "format" `S.rescue` const (return "json") +scottyBinfoBlockHeight :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () +scottyBinfoBlockHeight = + getNumTxId >>= \numtxid -> + withMetrics rawBlockResponseTime 1 $ + S.param "height" >>= \height -> + getBlocksAtHeight height >>= \block_hashes -> do + block_headers <- catMaybes <$> mapM getBlock block_hashes + next_block_hashes <- getBlocksAtHeight (height + 1) + next_block_headers <- catMaybes <$> mapM getBlock next_block_hashes + binfo_blocks <- + mapM (get_binfo_blocks numtxid next_block_headers) block_headers + setHeaders + net <- lift $ asks (storeNetwork . webStore . webConfig) + streamEncoding $ binfoBlocksToEncoding net binfo_blocks + where + get_tx th = + withRunInIO $ \run -> + unsafeInterleaveIO $ + run $ fromJust <$> getTransaction th + get_binfo_blocks numtxid next_block_headers block_header = do + let my_hash = H.headerHash (blockDataHeader block_header) + get_prev = H.prevBlock . blockDataHeader + get_hash = H.headerHash . blockDataHeader + txs <- lift $ mapM get_tx (blockDataTxs block_header) + let next_blocks = map get_hash $ + filter ((== my_hash) . get_prev) + next_block_headers + let binfo_txs = map (toBinfoTxSimple numtxid) txs + binfo_block = toBinfoBlock block_header binfo_txs next_blocks + return binfo_block + scottyBinfoBlock :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyBinfoBlock = getNumTxId >>= \numtxid -> @@ -1583,7 +1719,16 @@ Nothing -> raise blockErrors ThingNotFound Just b -> do txs <- lift $ mapM get_tx (blockDataTxs b) - nxt <- getBlocksAtHeight (blockDataHeight b + 1) + let my_hash = H.headerHash (blockDataHeader b) + get_prev = H.prevBlock . blockDataHeader + get_hash = H.headerHash . blockDataHeader + nxt_headers <- + fmap catMaybes $ + mapM getBlock =<< + getBlocksAtHeight (blockDataHeight b + 1) + let nxt = map get_hash $ + filter ((== my_hash) . get_prev) + nxt_headers if hex then do let x = H.Block (blockDataHeader b) (map transactionData txs) @@ -1786,7 +1931,7 @@ parseBody = do b <- S.body case hex b <> bin b of - Left _ -> raise_ $ UserError "Failed to parse request body" + Left _ -> raise_ $ UserError "Failed to parse request body" Right x -> return x where bin = runGetL deserialize